[commit: ghc] master: Make HsDocString a newtype of ByteString (d1beebb)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/d1beebb881722109d6935941e541eb175a9d6c62/ghc

>---------------------------------------------------------------

commit d1beebb881722109d6935941e541eb175a9d6c62
Author: Simon Jakobi <simon.jakobi at gmail.com>
Date:   Wed May 30 20:38:18 2018 -0400

    Make HsDocString a newtype of ByteString
    
    Docstrings don't profit from FastString's interning, so we switch to
    a different type that doesn't incur this overhead.
    
    Updates the haddock submodule.
    
    Reviewers: alexbiehl, bgamari
    
    Reviewed By: alexbiehl, bgamari
    
    Subscribers: rwbarton, thomie, mpickering, carter
    
    GHC Trac Issues: #15157
    
    Differential Revision: https://phabricator.haskell.org/D4743


>---------------------------------------------------------------

d1beebb881722109d6935941e541eb175a9d6c62
 compiler/hsSyn/HsDoc.hs    | 45 +++++++++++++++++++++++++++++++++++++--------
 compiler/parser/Parser.y   | 10 +++++-----
 compiler/rename/RnHsDoc.hs |  2 +-
 utils/haddock              |  2 +-
 4 files changed, 44 insertions(+), 15 deletions(-)

diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs
index 7c6bdd9..cbe1d94 100644
--- a/compiler/hsSyn/HsDoc.hs
+++ b/compiler/hsSyn/HsDoc.hs
@@ -1,32 +1,61 @@
 {-# LANGUAGE CPP, DeriveDataTypeable #-}
 
-module HsDoc (
-  HsDocString(..),
-  LHsDocString,
-  ppr_mbDoc
+module HsDoc
+  ( HsDocString
+  , LHsDocString
+  , mkHsDocString
+  , mkHsDocStringUtf8ByteString
+  , unpackHDS
+  , hsDocStringToByteString
+  , ppr_mbDoc
   ) where
 
 #include "HsVersions.h"
 
 import GhcPrelude
 
+import Encoding
+import FastFunctions
 import Outputable
 import SrcLoc
-import FastString
 
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Internal as BS
 import Data.Data
+import Foreign
 
 -- | Haskell Documentation String
-newtype HsDocString = HsDocString FastString
+--
+-- Internally this is a UTF8-Encoded 'ByteString'.
+newtype HsDocString = HsDocString ByteString
   deriving (Eq, Show, Data)
 
 -- | Located Haskell Documentation String
 type LHsDocString = Located HsDocString
 
 instance Outputable HsDocString where
-  ppr (HsDocString fs) = ftext fs
+  ppr = text . unpackHDS
+
+mkHsDocString :: String -> HsDocString
+mkHsDocString s =
+  inlinePerformIO $ do
+    let len = utf8EncodedLength s
+    buf <- mallocForeignPtrBytes len
+    withForeignPtr buf $ \ptr -> do
+      utf8EncodeString ptr s
+      pure (HsDocString (BS.fromForeignPtr buf 0 len))
+
+-- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'.
+mkHsDocStringUtf8ByteString :: ByteString -> HsDocString
+mkHsDocStringUtf8ByteString = HsDocString
+
+unpackHDS :: HsDocString -> String
+unpackHDS = utf8DecodeByteString . hsDocStringToByteString
+
+-- | Return the contents of a 'HsDocString' as a UTF8-encoded 'ByteString'.
+hsDocStringToByteString :: HsDocString -> ByteString
+hsDocStringToByteString (HsDocString bs) = bs
 
 ppr_mbDoc :: Maybe LHsDocString -> SDoc
 ppr_mbDoc (Just doc) = ppr doc
 ppr_mbDoc Nothing    = empty
-
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 4c66fd7..c6face8 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -3470,24 +3470,24 @@ bars :: { ([SrcSpan],Int) }     -- One or more bars
 -- Documentation comments
 
 docnext :: { LHsDocString }
-  : DOCNEXT {% return (sL1 $1 (HsDocString (mkFastString (getDOCNEXT $1)))) }
+  : DOCNEXT {% return (sL1 $1 (mkHsDocString (getDOCNEXT $1))) }
 
 docprev :: { LHsDocString }
-  : DOCPREV {% return (sL1 $1 (HsDocString (mkFastString (getDOCPREV $1)))) }
+  : DOCPREV {% return (sL1 $1 (mkHsDocString (getDOCPREV $1))) }
 
 docnamed :: { Located (String, HsDocString) }
   : DOCNAMED {%
       let string = getDOCNAMED $1
           (name, rest) = break isSpace string
-      in return (sL1 $1 (name, HsDocString (mkFastString rest))) }
+      in return (sL1 $1 (name, mkHsDocString rest)) }
 
 docsection :: { Located (Int, HsDocString) }
   : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in
-        return (sL1 $1 (n, HsDocString (mkFastString doc))) }
+        return (sL1 $1 (n, mkHsDocString doc)) }
 
 moduleheader :: { Maybe LHsDocString }
         : DOCNEXT {% let string = getDOCNEXT $1 in
-                     return (Just (sL1 $1 (HsDocString (mkFastString string)))) }
+                     return (Just (sL1 $1 (mkHsDocString string))) }
 
 maybe_docprev :: { Maybe LHsDocString }
         : docprev                       { Just $1 }
diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs
index ac0731d..ac2589d 100644
--- a/compiler/rename/RnHsDoc.hs
+++ b/compiler/rename/RnHsDoc.hs
@@ -21,5 +21,5 @@ rnLHsDoc (L pos doc) = do
   return (L pos doc')
 
 rnHsDoc :: HsDocString -> RnM HsDocString
-rnHsDoc (HsDocString s) = return (HsDocString s)
+rnHsDoc = pure
 
diff --git a/utils/haddock b/utils/haddock
index 46ff230..90ad5b5 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 46ff2306f580c44915a6f3adb652f02b7f4edfe9
+Subproject commit 90ad5b5c3a1d8532babac7934ee5189c09ef484b