diff options
Diffstat (limited to 'compiler/GHC/Hs')
| -rw-r--r-- | compiler/GHC/Hs/Decls.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Doc.hs | 355 | ||||
| -rw-r--r-- | compiler/GHC/Hs/DocString.hs | 197 | ||||
| -rw-r--r-- | compiler/GHC/Hs/ImpExp.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Type.hs | 7 |
5 files changed, 447 insertions, 126 deletions
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index 40c54b629a..568783bdb5 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -686,8 +686,8 @@ pprConDecl (ConDeclH98 { con_name = L _ con , con_mb_cxt = mcxt , con_args = args , con_doc = doc }) - = sep [ ppr_mbDoc doc - , pprHsForAll (mkHsForAllInvisTele noAnn ex_tvs) mcxt + = pprMaybeWithDoc doc $ + sep [ pprHsForAll (mkHsForAllInvisTele noAnn ex_tvs) mcxt , ppr_details args ] where -- In ppr_details: let's not print the multiplicities (they are always 1, by @@ -703,7 +703,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_doc = doc }) - = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon + = pprMaybeWithDoc doc $ ppr_con_names cons <+> dcolon <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt, sep (ppr_args args ++ [ppr res_ty]) ]) where @@ -1172,7 +1172,7 @@ type instance Anno (DataFamInstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno DocDecl = SrcSpanAnnA +type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA type instance Anno OverlapMode = SrcSpanAnnP type instance Anno (DerivStrategy (GhcPass p)) = SrcAnn NoEpAnns diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs index 117ce3adad..91f584c8d9 100644 --- a/compiler/GHC/Hs/Doc.hs +++ b/compiler/GHC/Hs/Doc.hs @@ -1,161 +1,288 @@ - +-- | Types and functions for raw and lexed docstrings. {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} module GHC.Hs.Doc - ( HsDocString - , LHsDocString - , mkHsDocString - , mkHsDocStringUtf8ByteString - , isEmptyDocString - , unpackHDS - , hsDocStringToByteString - , ppr_mbDoc + ( HsDoc + , WithHsDocIdentifiers(..) + , hsDocIds + , LHsDoc + , pprHsDocDebug + , pprWithDoc + , pprMaybeWithDoc - , appendDocs - , concatDocs + , module GHC.Hs.DocString - , DeclDocMap(..) - , emptyDeclDocMap + , ExtractedTHDocs(..) - , ArgDocMap(..) - , emptyArgDocMap + , DocStructureItem(..) + , DocStructure - , ExtractedTHDocs(..) + , Docs(..) + , emptyDocs ) where import GHC.Prelude import GHC.Utils.Binary -import GHC.Utils.Encoding import GHC.Types.Name -import GHC.Utils.Outputable as Outputable +import GHC.Utils.Outputable as Outputable hiding ((<>)) import GHC.Types.SrcLoc +import qualified GHC.Data.EnumSet as EnumSet +import GHC.Data.EnumSet (EnumSet) +import GHC.Types.Avail +import GHC.Types.Name.Set +import GHC.Unit.Module.Name +import GHC.Driver.Flags -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C8 +import Control.Applicative (liftA2) import Data.Data import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe +import Data.List.NonEmpty (NonEmpty(..)) +import GHC.LanguageExtensions.Type +import qualified GHC.Utils.Outputable as O +import Language.Haskell.Syntax.Extension +import GHC.Hs.Extension +import GHC.Types.Unique.Map +import Data.List (sortBy) + +import GHC.Hs.DocString --- | Haskell Documentation String +-- | A docstring with the (probable) identifiers found in it. +type HsDoc = WithHsDocIdentifiers HsDocString + +-- | Annotate a value with the probable identifiers found in it +-- These will be used by haddock to generate links. +-- +-- The identifiers are bundled along with their location in the source file. +-- This is useful for tooling to know exactly where they originate. -- --- Internally this is a UTF8-Encoded 'ByteString'. -newtype HsDocString = HsDocString ByteString - -- There are at least two plausible Semigroup instances for this type: - -- - -- 1. Simple string concatenation. - -- 2. Concatenation as documentation paragraphs with newlines in between. - -- - -- To avoid confusion, we pass on defining an instance at all. - deriving (Eq, Show, Data) +-- This type is currently used in two places - for regular documentation comments, +-- with 'a' set to 'HsDocString', and for adding identifier information to +-- warnings, where 'a' is 'StringLiteral' +data WithHsDocIdentifiers a pass = WithHsDocIdentifiers + { hsDocString :: !a + , hsDocIdentifiers :: ![Located (IdP pass)] + } --- | Located Haskell Documentation String -type LHsDocString = Located HsDocString +deriving instance (Data pass, Data (IdP pass), Data a) => Data (WithHsDocIdentifiers a pass) +deriving instance (Eq (IdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass) -instance Binary HsDocString where - put_ bh (HsDocString bs) = put_ bh bs - get bh = HsDocString <$> get bh +-- | For compatibility with the existing @-ddump-parsed' output, we only show +-- the docstring. +-- +-- Use 'pprHsDoc' to show `HsDoc`'s internals. +instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where + ppr (WithHsDocIdentifiers s _ids) = ppr s -instance Outputable HsDocString where - ppr = doubleQuotes . text . unpackHDS +instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where + put_ bh (WithHsDocIdentifiers s ids) = do + put_ bh s + put_ bh ids + get bh = + liftA2 WithHsDocIdentifiers (get bh) (get bh) -isEmptyDocString :: HsDocString -> Bool -isEmptyDocString (HsDocString bs) = BS.null bs +-- | Extract a mapping from the lexed identifiers to the names they may +-- correspond to. +hsDocIds :: WithHsDocIdentifiers a GhcRn -> NameSet +hsDocIds (WithHsDocIdentifiers _ ids) = mkNameSet $ map unLoc ids -mkHsDocString :: String -> HsDocString -mkHsDocString s = HsDocString (utf8EncodeString s) +-- | Pretty print a thing with its doc +-- The docstring will include the comment decorators '-- |', '{-|' etc +-- and will come either before or after depending on how it was written +-- i.e it will come after the thing if it is a '-- ^' or '{-^' and before +-- otherwise. +pprWithDoc :: LHsDoc name -> SDoc -> SDoc +pprWithDoc doc = pprWithDocString (hsDocString $ unLoc doc) --- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. -mkHsDocStringUtf8ByteString :: ByteString -> HsDocString -mkHsDocStringUtf8ByteString = HsDocString +-- | See 'pprWithHsDoc' +pprMaybeWithDoc :: Maybe (LHsDoc name) -> SDoc -> SDoc +pprMaybeWithDoc Nothing = id +pprMaybeWithDoc (Just doc) = pprWithDoc doc -unpackHDS :: HsDocString -> String -unpackHDS = utf8DecodeByteString . hsDocStringToByteString +-- | Print a doc with its identifiers, useful for debugging +pprHsDocDebug :: (Outputable (IdP name)) => HsDoc name -> SDoc +pprHsDocDebug (WithHsDocIdentifiers s ids) = + vcat [ text "text:" $$ nest 2 (pprHsDocString s) + , text "identifiers:" $$ nest 2 (vcat (map pprLocatedAlways ids)) + ] --- | Return the contents of a 'HsDocString' as a UTF8-encoded 'ByteString'. -hsDocStringToByteString :: HsDocString -> ByteString -hsDocStringToByteString (HsDocString bs) = bs +type LHsDoc pass = Located (HsDoc pass) -ppr_mbDoc :: Maybe LHsDocString -> SDoc -ppr_mbDoc (Just doc) = ppr doc -ppr_mbDoc Nothing = empty +-- | A simplified version of 'HsImpExp.IE'. +data DocStructureItem + = DsiSectionHeading Int (HsDoc GhcRn) + | DsiDocChunk (HsDoc GhcRn) + | DsiNamedChunkRef String + | DsiExports Avails + | DsiModExport + (NonEmpty ModuleName) -- ^ We might re-export avails from multiple + -- modules with a single export declaration. E.g. + -- when we have + -- + -- > module M (module X) where + -- > import R0 as X + -- > import R1 as X + Avails --- | Join two docstrings. --- --- Non-empty docstrings are joined with two newlines in between, --- resulting in separate paragraphs. -appendDocs :: HsDocString -> HsDocString -> HsDocString -appendDocs x y = - fromMaybe - (HsDocString BS.empty) - (concatDocs [x, y]) - --- | Concat docstrings with two newlines in between. --- --- Empty docstrings are skipped. --- --- If all inputs are empty, 'Nothing' is returned. -concatDocs :: [HsDocString] -> Maybe HsDocString -concatDocs xs = - if BS.null b - then Nothing - else Just (HsDocString b) - where - b = BS.intercalate (C8.pack "\n\n") - . filter (not . BS.null) - . map hsDocStringToByteString - $ xs - --- | Docs for declarations: functions, data types, instances, methods etc. -newtype DeclDocMap = DeclDocMap (Map Name HsDocString) - -instance Binary DeclDocMap where - put_ bh (DeclDocMap m) = put_ bh (Map.toList m) - -- We can't rely on a deterministic ordering of the `Name`s here. - -- See the comments on `Name`'s `Ord` instance for context. - get bh = DeclDocMap . Map.fromList <$> get bh - -instance Outputable DeclDocMap where - ppr (DeclDocMap m) = vcat (map pprPair (Map.toAscList m)) - where - pprPair (name, doc) = ppr name Outputable.<> colon $$ nest 2 (ppr doc) +instance Binary DocStructureItem where + put_ bh = \case + DsiSectionHeading level doc -> do + putByte bh 0 + put_ bh level + put_ bh doc + DsiDocChunk doc -> do + putByte bh 1 + put_ bh doc + DsiNamedChunkRef name -> do + putByte bh 2 + put_ bh name + DsiExports avails -> do + putByte bh 3 + put_ bh avails + DsiModExport mod_names avails -> do + putByte bh 4 + put_ bh mod_names + put_ bh avails + + get bh = do + tag <- getByte bh + case tag of + 0 -> DsiSectionHeading <$> get bh <*> get bh + 1 -> DsiDocChunk <$> get bh + 2 -> DsiNamedChunkRef <$> get bh + 3 -> DsiExports <$> get bh + 4 -> DsiModExport <$> get bh <*> get bh + _ -> fail "instance Binary DocStructureItem: Invalid tag" + +instance Outputable DocStructureItem where + ppr = \case + DsiSectionHeading level doc -> vcat + [ text "section heading, level" <+> ppr level O.<> colon + , nest 2 (pprHsDocDebug doc) + ] + DsiDocChunk doc -> vcat + [ text "documentation chunk:" + , nest 2 (pprHsDocDebug doc) + ] + DsiNamedChunkRef name -> + text "reference to named chunk:" <+> text name + DsiExports avails -> + text "avails:" $$ nest 2 (ppr avails) + DsiModExport mod_names avails -> + text "re-exported module(s):" <+> ppr mod_names $$ nest 2 (ppr avails) -emptyDeclDocMap :: DeclDocMap -emptyDeclDocMap = DeclDocMap Map.empty +type DocStructure = [DocStructureItem] --- | Docs for arguments. E.g. function arguments, method arguments. -newtype ArgDocMap = ArgDocMap (Map Name (IntMap HsDocString)) +data Docs = Docs + { docs_mod_hdr :: Maybe (HsDoc GhcRn) + -- ^ Module header. + , docs_decls :: UniqMap Name [HsDoc GhcRn] + -- ^ Docs for declarations: functions, data types, instances, methods etc. + -- A list because sometimes subsequent haddock comments can be combined into one + , docs_args :: UniqMap Name (IntMap (HsDoc GhcRn)) + -- ^ Docs for arguments. E.g. function arguments, method arguments. + , docs_structure :: DocStructure + , docs_named_chunks :: Map String (HsDoc GhcRn) + -- ^ Map from chunk name to content. + -- + -- This map will be empty unless we have an explicit export list from which + -- we can reference the chunks. + , docs_haddock_opts :: Maybe String + -- ^ Haddock options from @OPTIONS_HADDOCK@ or from @-haddock-opts@. + , docs_language :: Maybe Language + -- ^ The 'Language' used in the module, for example 'Haskell2010'. + , docs_extensions :: EnumSet Extension + -- ^ The full set of language extensions used in the module. + } -instance Binary ArgDocMap where - put_ bh (ArgDocMap m) = put_ bh (Map.toList (IntMap.toAscList <$> m)) - -- We can't rely on a deterministic ordering of the `Name`s here. - -- See the comments on `Name`'s `Ord` instance for context. - get bh = ArgDocMap . fmap IntMap.fromDistinctAscList . Map.fromList <$> get bh +instance Binary Docs where + put_ bh docs = do + put_ bh (docs_mod_hdr docs) + put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ docs_decls docs) + put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ docs_args docs) + put_ bh (docs_structure docs) + put_ bh (Map.toList $ docs_named_chunks docs) + put_ bh (docs_haddock_opts docs) + put_ bh (docs_language docs) + put_ bh (docs_extensions docs) + get bh = do + mod_hdr <- get bh + decls <- listToUniqMap <$> get bh + args <- listToUniqMap <$> get bh + structure <- get bh + named_chunks <- Map.fromList <$> get bh + haddock_opts <- get bh + language <- get bh + exts <- get bh + pure Docs { docs_mod_hdr = mod_hdr + , docs_decls = decls + , docs_args = args + , docs_structure = structure + , docs_named_chunks = named_chunks + , docs_haddock_opts = haddock_opts + , docs_language = language + , docs_extensions = exts + } -instance Outputable ArgDocMap where - ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m)) +instance Outputable Docs where + ppr docs = + vcat + [ pprField (pprMaybe pprHsDocDebug) "module header" docs_mod_hdr + , pprField (ppr . fmap (ppr . map pprHsDocDebug)) "declaration docs" docs_decls + , pprField (ppr . fmap (pprIntMap ppr pprHsDocDebug)) "arg docs" docs_args + , pprField (vcat . map ppr) "documentation structure" docs_structure + , pprField (pprMap (doubleQuotes . text) pprHsDocDebug) "named chunks" + docs_named_chunks + , pprField pprMbString "haddock options" docs_haddock_opts + , pprField ppr "language" docs_language + , pprField (vcat . map ppr . EnumSet.toList) "language extensions" + docs_extensions + ] where - pprPair (name, int_map) = - ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map) - pprIntMap im = vcat (map pprIPair (IntMap.toAscList im)) - pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc) + pprField :: (a -> SDoc) -> String -> (Docs -> a) -> SDoc + pprField ppr' heading lbl = + text heading O.<> colon $$ nest 2 (ppr' (lbl docs)) + pprMap pprKey pprVal m = + vcat $ flip map (Map.toList m) $ \(k, v) -> + pprKey k O.<> colon $$ nest 2 (pprVal v) + pprIntMap pprKey pprVal m = + vcat $ flip map (IntMap.toList m) $ \(k, v) -> + pprKey k O.<> colon $$ nest 2 (pprVal v) + pprMbString Nothing = empty + pprMbString (Just s) = text s + pprMaybe ppr' = \case + Nothing -> text "Nothing" + Just x -> text "Just" <+> ppr' x -emptyArgDocMap :: ArgDocMap -emptyArgDocMap = ArgDocMap Map.empty +emptyDocs :: Docs +emptyDocs = Docs + { docs_mod_hdr = Nothing + , docs_decls = emptyUniqMap + , docs_args = emptyUniqMap + , docs_structure = [] + , docs_named_chunks = Map.empty + , docs_haddock_opts = Nothing + , docs_language = Nothing + , docs_extensions = EnumSet.empty + } -- | Maps of docs that were added via Template Haskell's @putDoc@. data ExtractedTHDocs = ExtractedTHDocs - { ethd_mod_header :: Maybe HsDocString + { ethd_mod_header :: Maybe (HsDoc GhcRn) -- ^ The added module header documentation, if it exists. - , ethd_decl_docs :: DeclDocMap + , ethd_decl_docs :: UniqMap Name (HsDoc GhcRn) -- ^ The documentation added to declarations. - , ethd_arg_docs :: ArgDocMap + , ethd_arg_docs :: UniqMap Name (IntMap (HsDoc GhcRn)) -- ^ The documentation added to function arguments. - , ethd_inst_docs :: DeclDocMap + , ethd_inst_docs :: UniqMap Name (HsDoc GhcRn) -- ^ The documentation added to class and family instances. } diff --git a/compiler/GHC/Hs/DocString.hs b/compiler/GHC/Hs/DocString.hs new file mode 100644 index 0000000000..3a557ee0e8 --- /dev/null +++ b/compiler/GHC/Hs/DocString.hs @@ -0,0 +1,197 @@ +-- | An exactprintable structure for docstrings +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Hs.DocString + ( LHsDocString + , HsDocString(..) + , HsDocStringDecorator(..) + , HsDocStringChunk(..) + , LHsDocStringChunk + , isEmptyDocString + , unpackHDSC + , mkHsDocStringChunk + , mkHsDocStringChunkUtf8ByteString + , pprHsDocString + , pprHsDocStrings + , mkGeneratedHsDocString + , docStringChunks + , renderHsDocString + , renderHsDocStrings + , exactPrintHsDocString + , pprWithDocString + ) where + +import GHC.Prelude + +import GHC.Utils.Binary +import GHC.Utils.Encoding +import GHC.Utils.Outputable as Outputable hiding ((<>)) +import GHC.Types.SrcLoc + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Data +import Data.List.NonEmpty (NonEmpty(..)) +import Data.List (intercalate) + +type LHsDocString = Located HsDocString + +-- | Haskell Documentation String +-- +-- Rich structure to support exact printing +-- The location around each chunk doesn't include the decorators +data HsDocString + = MultiLineDocString !HsDocStringDecorator !(NonEmpty LHsDocStringChunk) + -- ^ The first chunk is preceded by "-- <decorator>" and each following chunk is preceded by "--" + -- Example: -- | This is a docstring for 'foo'. It is the line with the decorator '|' and is always included + -- -- This continues that docstring and is the second element in the NonEmpty list + -- foo :: a -> a + | NestedDocString !HsDocStringDecorator LHsDocStringChunk + -- ^ The docstring is preceded by "{-<decorator>" and followed by "-}" + -- The chunk contains balanced pairs of '{-' and '-}' + | GeneratedDocString HsDocStringChunk + -- ^ A docstring generated either internally or via TH + -- Pretty printed with the '-- |' decorator + -- This is because it may contain unbalanced pairs of '{-' and '-}' and + -- not form a valid 'NestedDocString' + deriving (Eq, Data, Show) + +instance Outputable HsDocString where + ppr = text . renderHsDocString + +-- | Annotate a pretty printed thing with its doc +-- The docstring comes after if is 'HsDocStringPrevious' +-- Otherwise it comes before. +-- Note - we convert MultiLineDocString HsDocStringPrevious to HsDocStringNext +-- because we can't control if something else will be pretty printed on the same line +pprWithDocString :: HsDocString -> SDoc -> SDoc +pprWithDocString (MultiLineDocString HsDocStringPrevious ds) sd = pprWithDocString (MultiLineDocString HsDocStringNext ds) sd +pprWithDocString doc@(NestedDocString HsDocStringPrevious _) sd = sd <+> pprHsDocString doc +pprWithDocString doc sd = pprHsDocString doc $+$ sd + + +instance Binary HsDocString where + put_ bh x = case x of + MultiLineDocString dec xs -> do + putByte bh 0 + put_ bh dec + put_ bh xs + NestedDocString dec x -> do + putByte bh 1 + put_ bh dec + put_ bh x + GeneratedDocString x -> do + putByte bh 2 + put_ bh x + get bh = do + tag <- getByte bh + case tag of + 0 -> MultiLineDocString <$> get bh <*> get bh + 1 -> NestedDocString <$> get bh <*> get bh + 2 -> GeneratedDocString <$> get bh + t -> fail $ "HsDocString: invalid tag " ++ show t + +data HsDocStringDecorator + = HsDocStringNext -- ^ '|' is the decorator + | HsDocStringPrevious -- ^ '^' is the decorator + | HsDocStringNamed !String -- ^ '$<string>' is the decorator + | HsDocStringGroup !Int -- ^ The decorator is the given number of '*'s + deriving (Eq, Ord, Show, Data) + +instance Outputable HsDocStringDecorator where + ppr = text . printDecorator + +printDecorator :: HsDocStringDecorator -> String +printDecorator HsDocStringNext = "|" +printDecorator HsDocStringPrevious = "^" +printDecorator (HsDocStringNamed n) = '$':n +printDecorator (HsDocStringGroup n) = replicate n '*' + +instance Binary HsDocStringDecorator where + put_ bh x = case x of + HsDocStringNext -> putByte bh 0 + HsDocStringPrevious -> putByte bh 1 + HsDocStringNamed n -> putByte bh 2 >> put_ bh n + HsDocStringGroup n -> putByte bh 3 >> put_ bh n + get bh = do + tag <- getByte bh + case tag of + 0 -> pure HsDocStringNext + 1 -> pure HsDocStringPrevious + 2 -> HsDocStringNamed <$> get bh + 3 -> HsDocStringGroup <$> get bh + t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t + +type LHsDocStringChunk = Located HsDocStringChunk + +-- | A continguous chunk of documentation +newtype HsDocStringChunk = HsDocStringChunk ByteString + deriving (Eq,Ord,Data, Show) + +instance Binary HsDocStringChunk where + put_ bh (HsDocStringChunk bs) = put_ bh bs + get bh = HsDocStringChunk <$> get bh + +instance Outputable HsDocStringChunk where + ppr = text . unpackHDSC + + +mkHsDocStringChunk :: String -> HsDocStringChunk +mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeString s) + +-- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. +mkHsDocStringChunkUtf8ByteString :: ByteString -> HsDocStringChunk +mkHsDocStringChunkUtf8ByteString = HsDocStringChunk + +unpackHDSC :: HsDocStringChunk -> String +unpackHDSC (HsDocStringChunk bs) = utf8DecodeByteString bs + +nullHDSC :: HsDocStringChunk -> Bool +nullHDSC (HsDocStringChunk bs) = BS.null bs + +mkGeneratedHsDocString :: String -> HsDocString +mkGeneratedHsDocString = GeneratedDocString . mkHsDocStringChunk + +isEmptyDocString :: HsDocString -> Bool +isEmptyDocString (MultiLineDocString _ xs) = all (nullHDSC . unLoc) xs +isEmptyDocString (NestedDocString _ s) = nullHDSC $ unLoc s +isEmptyDocString (GeneratedDocString x) = nullHDSC x + +docStringChunks :: HsDocString -> [LHsDocStringChunk] +docStringChunks (MultiLineDocString _ (x:|xs)) = x:xs +docStringChunks (NestedDocString _ x) = [x] +docStringChunks (GeneratedDocString x) = [L (UnhelpfulSpan UnhelpfulGenerated) x] + +-- | Pretty print with decorators, exactly as the user wrote it +pprHsDocString :: HsDocString -> SDoc +pprHsDocString = text . exactPrintHsDocString + +pprHsDocStrings :: [HsDocString] -> SDoc +pprHsDocStrings = text . intercalate "\n\n" . map exactPrintHsDocString + +-- | Pretty print with decorators, exactly as the user wrote it +exactPrintHsDocString :: HsDocString -> String +exactPrintHsDocString (MultiLineDocString dec (x :| xs)) + = unlines' $ ("-- " ++ printDecorator dec ++ unpackHDSC (unLoc x)) + : map (\x -> "--" ++ unpackHDSC (unLoc x)) xs +exactPrintHsDocString (NestedDocString dec (L _ s)) + = "{-" ++ printDecorator dec ++ unpackHDSC s ++ "-}" +exactPrintHsDocString (GeneratedDocString x) = case lines (unpackHDSC x) of + [] -> "" + (x:xs) -> unlines' $ ( "-- |" ++ x) + : map (\y -> "--"++y) xs + +-- | Just get the docstring, without any decorators +renderHsDocString :: HsDocString -> String +renderHsDocString (MultiLineDocString _ (x :| xs)) = unlines' $ map (unpackHDSC . unLoc) (x:xs) +renderHsDocString (NestedDocString _ ds) = unpackHDSC $ unLoc ds +renderHsDocString (GeneratedDocString x) = unpackHDSC x + +-- | Don't add a newline to a single string +unlines' :: [String] -> String +unlines' = intercalate "\n" + +-- | Just get the docstring, without any decorators +-- Seperates docstrings using "\n\n", which is how haddock likes to render them +renderHsDocStrings :: [HsDocString] -> String +renderHsDocStrings = intercalate "\n\n" . map renderHsDocString diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index fa16da9fdc..22c83e6e2a 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -19,7 +19,7 @@ module GHC.Hs.ImpExp where import GHC.Prelude import GHC.Unit.Module ( ModuleName, IsBootInterface(..) ) -import GHC.Hs.Doc ( HsDocString ) +import GHC.Hs.Doc import GHC.Types.SourceText ( SourceText(..) ) import GHC.Types.FieldLabel ( FieldLabel ) @@ -279,8 +279,8 @@ data IE pass -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | IEGroup (XIEGroup pass) Int HsDocString -- ^ Doc section heading - | IEDoc (XIEDoc pass) HsDocString -- ^ Some documentation + | IEGroup (XIEGroup pass) Int (LHsDoc pass) -- ^ Doc section heading + | IEDoc (XIEDoc pass) (LHsDoc pass) -- ^ Some documentation | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc | XIE !(XXIE pass) diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 2b17df420e..40dc281a74 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -1005,7 +1005,7 @@ pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, cd_fld_doc = doc })) - = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc + = pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty) ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc ppr_names [n] = pprPrefixOcc n @@ -1094,10 +1094,7 @@ ppr_mono_ty (HsParTy _ ty) -- toHsType doesn't put in any HsParTys, so we may still need them ppr_mono_ty (HsDocTy _ ty doc) - -- AZ: Should we add parens? Should we introduce "-- ^"? - = ppr_mono_lty ty <+> ppr (unLoc doc) - -- we pretty print Haddock comments on types as if they were - -- postfix operators + = pprWithDoc doc $ ppr_mono_lty ty ppr_mono_ty (XHsType t) = ppr t |