diff options
Diffstat (limited to 'compiler/GHC/Hs/Doc.hs')
| -rw-r--r-- | compiler/GHC/Hs/Doc.hs | 355 |
1 files changed, 241 insertions, 114 deletions
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. } |