diff options
-rw-r--r-- | compiler/hsSyn/HsDoc.hs | 45 | ||||
-rw-r--r-- | compiler/parser/Parser.y | 10 | ||||
-rw-r--r-- | compiler/rename/RnHsDoc.hs | 2 | ||||
m--------- | utils/haddock | 0 |
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 |