summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/hsSyn/HsDoc.hs45
-rw-r--r--compiler/parser/Parser.y10
-rw-r--r--compiler/rename/RnHsDoc.hs2
m---------utils/haddock0
4 files changed, 43 insertions, 14 deletions
diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs
index 7c6bdd9431..cbe1d94bec 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 4c66fd76d6..c6face8be2 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 ac0731d50a..ac2589df4e 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
-Subproject 46ff2306f580c44915a6f3adb652f02b7f4edfe
+Subproject 90ad5b5c3a1d8532babac7934ee5189c09ef484