diff options
Diffstat (limited to 'compiler')
51 files changed, 1589 insertions, 644 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 2d2de4550b..c62f4baa3b 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -1171,7 +1171,7 @@ instance DesugaredMod DesugaredModule where type ParsedSource = Located HsModule type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe LHsDocString) + Maybe (LHsDoc GhcRn)) type TypecheckedSource = LHsBinds GhcTc -- NOTE: diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs index c577c46b75..a815c5e5bb 100644 --- a/compiler/GHC/Builtin/Utils.hs +++ b/compiler/GHC/Builtin/Utils.hs @@ -65,6 +65,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Id.Make import GHC.Types.Unique.FM +import GHC.Types.Unique.Map import GHC.Types.TyThing import GHC.Types.Unique ( isValidKnownKeyUnique ) @@ -80,7 +81,6 @@ import GHC.Data.List.SetOps import Control.Applicative ((<|>)) import Data.List ( intercalate , find ) import Data.Maybe -import qualified Data.Map as Map {- ************************************************************************ @@ -244,15 +244,15 @@ ghcPrimExports [ availTC n [n] [] | tc <- exposedPrimTyCons, let n = tyConName tc ] -ghcPrimDeclDocs :: DeclDocMap -ghcPrimDeclDocs = DeclDocMap $ Map.fromList $ mapMaybe findName primOpDocs +ghcPrimDeclDocs :: Docs +ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs } where names = map idName ghcPrimIds ++ map idName allThePrimOpIds ++ map tyConName exposedPrimTyCons findName (nameStr, doc) | Just name <- find ((nameStr ==) . getOccString) names - = Just (name, mkHsDocString doc) + = Just (name, [WithHsDocIdentifiers (mkGeneratedHsDocString doc) []]) | otherwise = Nothing {- diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs index 507d5243b9..1f1ff9ebc0 100644 --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -171,7 +171,7 @@ basicBlockCodeGen block = do -- ----------------------------------------------------------------------------- -- | Utilities ann :: SDoc -> Instr -> Instr -ann doc instr {- | debugIsOn -} = ANN doc instr +ann doc instr {- debugIsOn -} = ANN doc instr -- ann _ instr = instr {-# INLINE ann #-} @@ -199,7 +199,7 @@ ann doc instr {- | debugIsOn -} = ANN doc instr -- forced until we actually force them, and without -dppr-debug they should -- never end up being forced. annExpr :: CmmExpr -> Instr -> Instr -annExpr e instr {- | debugIsOn -} = ANN (text . show $ e) instr +annExpr e instr {- debugIsOn -} = ANN (text . show $ e) instr -- annExpr e instr {- | debugIsOn -} = ANN (pprExpr genericPlatform e) instr -- annExpr _ instr = instr {-# INLINE annExpr #-} diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 78ed3a104c..bfbd2000cb 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -16,7 +16,7 @@ module GHC.Core.FamInstEnv ( FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, unionFamInstEnv, extendFamInstEnv, extendFamInstEnvList, - famInstEnvElts, famInstEnvSize, familyInstances, + famInstEnvElts, famInstEnvSize, familyInstances, familyNameInstances, -- * CoAxioms mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, @@ -397,11 +397,15 @@ famInstEnvElts (FamIE _ rm) = elemsRM rm -- size. familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] -familyInstances (pkg_fie, home_fie) fam +familyInstances envs tc + = familyNameInstances envs (tyConName tc) + +familyNameInstances :: (FamInstEnv, FamInstEnv) -> Name -> [FamInst] +familyNameInstances (pkg_fie, home_fie) fam = get home_fie ++ get pkg_fie where get :: FamInstEnv -> [FamInst] - get (FamIE _ env) = lookupRM [RML_KnownTc (tyConName fam)] env + get (FamIE _ env) = lookupRM [RML_KnownTc fam] env -- | Makes no particular effort to detect conflicts. diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index e223a7cd87..63dde6f6b5 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -27,6 +27,7 @@ module GHC.Core.InstEnv ( memberInstEnv, instIsVisible, classInstances, instanceBindFun, + classNameInstances, instanceCantMatch, roughMatchTcs, isOverlappable, isOverlapping, isIncoherent ) where @@ -435,8 +436,8 @@ instEnvElts :: InstEnv -> [ClsInst] instEnvElts (InstEnv rm) = elemsRM rm -- See Note [InstEnv determinism] -instEnvEltsForClass :: InstEnv -> Class -> [ClsInst] -instEnvEltsForClass (InstEnv rm) cls = lookupRM [RML_KnownTc (className cls)] rm +instEnvEltsForClass :: InstEnv -> Name -> [ClsInst] +instEnvEltsForClass (InstEnv rm) cls_nm = lookupRM [RML_KnownTc cls_nm] rm -- N.B. this is not particularly efficient but used only by GHCi. instEnvClasses :: InstEnv -> UniqDSet Class @@ -457,7 +458,10 @@ instIsVisible vis_mods ispec | otherwise -> True classInstances :: InstEnvs -> Class -> [ClsInst] -classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls +classInstances envs cls = classNameInstances envs (className cls) + +classNameInstances :: InstEnvs -> Name -> [ClsInst] +classNameInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls = get home_ie ++ get pkg_ie where get :: InstEnv -> [ClsInst] diff --git a/compiler/GHC/Data/EnumSet.hs b/compiler/GHC/Data/EnumSet.hs index a7949c7e71..d364dc05d7 100644 --- a/compiler/GHC/Data/EnumSet.hs +++ b/compiler/GHC/Data/EnumSet.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' -- things. module GHC.Data.EnumSet @@ -12,10 +14,12 @@ module GHC.Data.EnumSet ) where import GHC.Prelude +import GHC.Utils.Binary import qualified Data.IntSet as IntSet newtype EnumSet a = EnumSet IntSet.IntSet + deriving (Semigroup, Monoid) member :: Enum a => a -> EnumSet a -> Bool member x (EnumSet s) = IntSet.member (fromEnum x) s @@ -37,3 +41,30 @@ empty = EnumSet IntSet.empty difference :: EnumSet a -> EnumSet a -> EnumSet a difference (EnumSet a) (EnumSet b) = EnumSet (IntSet.difference a b) + +-- | Represents the 'EnumSet' as a bit set. +-- +-- Assumes that all elements are non-negative. +-- +-- This is only efficient for values that are sufficiently small, +-- for example in the lower hundreds. +instance Binary (EnumSet a) where + put_ bh = put_ bh . enumSetToBitArray + get bh = bitArrayToEnumSet <$> get bh + +-- TODO: Using 'Natural' instead of 'Integer' should be slightly more efficient +-- but we don't currently have a 'Binary' instance for 'Natural'. +type BitArray = Integer + +enumSetToBitArray :: EnumSet a -> BitArray +enumSetToBitArray (EnumSet int_set) = + IntSet.foldl' setBit 0 int_set + +bitArrayToEnumSet :: BitArray -> EnumSet a +bitArrayToEnumSet ba = EnumSet (go (popCount ba) 0 IntSet.empty) + where + go 0 _ !int_set = int_set + go n i !int_set = + if ba `testBit` i + then go (pred n) (succ i) (IntSet.insert i int_set) + else go n (succ i) int_set diff --git a/compiler/GHC/Data/StringBuffer.hs b/compiler/GHC/Data/StringBuffer.hs index 03d720eb37..e6dcb14b6b 100644 --- a/compiler/GHC/Data/StringBuffer.hs +++ b/compiler/GHC/Data/StringBuffer.hs @@ -26,6 +26,7 @@ module GHC.Data.StringBuffer hPutStringBuffer, appendStringBuffers, stringToStringBuffer, + stringBufferFromByteString, -- * Inspection nextChar, @@ -68,6 +69,10 @@ import System.IO.Unsafe ( unsafePerformIO ) import GHC.IO.Encoding.UTF8 ( mkUTF8 ) import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) ) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString as BS +import Data.ByteString ( ByteString ) + import GHC.Exts import Foreign @@ -199,6 +204,15 @@ stringToStringBuffer str = -- sentinels for UTF-8 decoding return (StringBuffer buf size 0) +-- | Convert a UTF-8 encoded 'ByteString' into a 'StringBuffer. This really +-- relies on the internals of both 'ByteString' and 'StringBuffer'. +-- +-- /O(n)/ (but optimized into a @memcpy@ by @bytestring@ under the hood) +stringBufferFromByteString :: ByteString -> StringBuffer +stringBufferFromByteString bs = + let BS.PS fp off len = BS.append bs (BS.pack [0,0,0]) + in StringBuffer { buf = fp, len = len - 3, cur = off } + -- ----------------------------------------------------------------------------- -- Grab a character diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 1d1222fbab..a2ac1b75f4 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -21,19 +21,23 @@ where import GHC.Prelude import GHC.Utils.Outputable +import GHC.Utils.Binary import GHC.Data.EnumSet as EnumSet import Control.Monad (guard) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromMaybe,mapMaybe) - data Language = Haskell98 | Haskell2010 | GHC2021 deriving (Eq, Enum, Show, Bounded) instance Outputable Language where ppr = text . show +instance Binary Language where + put_ bh = put_ bh . fromEnum + get bh = toEnum <$> get bh + -- | Debugging flags data DumpFlag -- See Note [Updating flag description in the User's Guide] diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index 0045588eaf..b0eb32b380 100644 --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -96,7 +96,7 @@ data HsModule -- downstream. hsmodDecls :: [LHsDecl GhcPs], -- ^ Type, class, value, and interface signature decls - hsmodDeprecMessage :: Maybe (LocatedP WarningTxt), + hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs)), -- ^ reason\/explanation for warning/deprecation of this module -- -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen' @@ -104,7 +104,7 @@ data HsModule -- -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - hsmodHaddockModHeader :: Maybe LHsDocString + hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs) -- ^ Haddock module info and description, unparsed -- -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen' @@ -133,13 +133,13 @@ data AnnsModule instance Outputable HsModule where ppr (HsModule _ _ Nothing _ imports decls _ mbDoc) - = pp_mb mbDoc $$ pp_nonnull imports - $$ pp_nonnull decls + = pprMaybeWithDoc mbDoc $ pp_nonnull imports + $$ pp_nonnull decls ppr (HsModule _ _ (Just name) exports imports decls deprec mbDoc) - = vcat [ - pp_mb mbDoc, - case exports of + = pprMaybeWithDoc mbDoc $ + vcat + [ case exports of Nothing -> pp_header (text "where") Just es -> vcat [ pp_header lparen, @@ -156,10 +156,6 @@ instance Outputable HsModule where pp_modname = text "module" <+> ppr name -pp_mb :: Outputable t => Maybe t -> SDoc -pp_mb (Just x) = ppr x -pp_mb Nothing = empty - pp_nonnull :: Outputable t => [t] -> SDoc pp_nonnull [] = empty pp_nonnull xs = vcat (map ppr xs) 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 diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 78d43b164f..b95a5aebbe 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -225,7 +225,7 @@ deSugar hsc_env ; foreign_files <- readIORef th_foreign_files_var - ; (doc_hdr, decl_docs, arg_docs) <- extractDocs tcg_env + ; docs <- extractDocs dflags tcg_env ; let mod_guts = ModGuts { mg_module = mod, @@ -255,9 +255,7 @@ deSugar hsc_env mg_safe_haskell = safe_mode, mg_trust_pkg = imp_trust_own_pkg imports, mg_complete_matches = complete_matches, - mg_doc_hdr = doc_hdr, - mg_decl_docs = decl_docs, - mg_arg_docs = arg_docs + mg_docs = docs } ; return (msgs, Just mod_guts) }}}} diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index 15771cd26e..c4839ae449 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -8,8 +8,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.HsToCore.Docs where import GHC.Prelude @@ -32,89 +30,237 @@ import Control.Monad.IO.Class import Data.Bifunctor (first) import Data.IntMap (IntMap) import qualified Data.IntMap as IM -import Data.Map (Map) +import Data.Map.Strict (Map) import qualified Data.Map as M +import qualified Data.Set as Set import Data.Maybe import Data.Semigroup import GHC.IORef (readIORef) +import GHC.Unit.Types +import GHC.Hs +import GHC.Types.Avail +import GHC.Unit.Module +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty ((:|))) +import GHC.Unit.Module.Imported +import GHC.Driver.Session +import GHC.Types.TypeEnv +import GHC.Types.Id +import GHC.Types.Unique.Map -- | Extract docs from renamer output. -- This is monadic since we need to be able to read documentation added from -- Template Haskell's @putDoc@, which is stored in 'tcg_th_docs'. extractDocs :: MonadIO m - => TcGblEnv - -> m (Maybe HsDocString, DeclDocMap, ArgDocMap) + => DynFlags -> TcGblEnv + -> m (Maybe Docs) -- ^ -- 1. Module header -- 2. Docs on top level declarations -- 3. Docs on arguments -extractDocs TcGblEnv { tcg_semantic_mod = mod - , tcg_rn_decls = mb_rn_decls - , tcg_insts = insts - , tcg_fam_insts = fam_insts - , tcg_doc_hdr = mb_doc_hdr - , tcg_th_docs = th_docs_var - } = do +extractDocs dflags + TcGblEnv { tcg_semantic_mod = semantic_mdl + , tcg_mod = mdl + , tcg_rn_decls = Just rn_decls + , tcg_rn_exports = mb_rn_exports + , tcg_exports = all_exports + , tcg_imports = import_avails + , tcg_insts = insts + , tcg_fam_insts = fam_insts + , tcg_doc_hdr = mb_doc_hdr + , tcg_th_docs = th_docs_var + , tcg_type_env = ty_env + } = do th_docs <- liftIO $ readIORef th_docs_var - let doc_hdr = th_doc_hdr <|> (unLoc <$> mb_doc_hdr) - ExtractedTHDocs - th_doc_hdr - (DeclDocMap th_doc_map) - (ArgDocMap th_arg_map) - (DeclDocMap th_inst_map) = extractTHDocs th_docs - return - ( doc_hdr - , DeclDocMap (th_doc_map <> th_inst_map <> doc_map) - , ArgDocMap (th_arg_map `unionArgMaps` arg_map) - ) + let doc_hdr = (unLoc <$> mb_doc_hdr) + ExtractedTHDocs th_hdr th_decl_docs th_arg_docs th_inst_docs = extractTHDocs th_docs + mod_docs + = Docs + { docs_mod_hdr = th_hdr <|> doc_hdr + -- Left biased union (see #21220) + , docs_decls = plusUniqMap_C (\a _ -> a) + ((:[]) <$> th_decl_docs `plusUniqMap` th_inst_docs) + -- These will not clash so safe to use plusUniqMap + doc_map + , docs_args = th_arg_docs `unionArgMaps` arg_map + , docs_structure = doc_structure + , docs_named_chunks = named_chunks + , docs_haddock_opts = haddockOptions dflags + , docs_language = language_ + , docs_extensions = exts + } + pure (Just mod_docs) where - (doc_map, arg_map) = maybe (M.empty, M.empty) - (mkMaps local_insts) - mb_decls_with_docs - mb_decls_with_docs = topDecls <$> mb_rn_decls - local_insts = filter (nameIsLocalOrFrom mod) + exts = extensionFlags dflags + language_ = language dflags + + -- We need to lookup the Names for default methods, so we + -- can put them in the correct map + -- See Note [default method Name] in GHC.Iface.Recomp + def_meths_env = mkOccEnv [(occ, nm) + | id <- typeEnvIds ty_env + , let nm = idName id + occ = nameOccName nm + , isDefaultMethodOcc occ + ] + + (doc_map, arg_map) = mkMaps def_meths_env local_insts decls_with_docs + decls_with_docs = topDecls rn_decls + local_insts = filter (nameIsLocalOrFrom semantic_mdl) $ map getName insts ++ map getName fam_insts + doc_structure = mkDocStructure mdl import_avails mb_rn_exports rn_decls + all_exports def_meths_env + named_chunks = getNamedChunks (isJust mb_rn_exports) rn_decls +extractDocs _ _ = pure Nothing + +-- | If we have an explicit export list, we extract the documentation structure +-- from that. +-- Otherwise we use the renamed exports and declarations. +mkDocStructure :: Module -- ^ The current module + -> ImportAvails -- ^ Imports + -> Maybe [(LIE GhcRn, Avails)] -- ^ Explicit export list + -> HsGroup GhcRn + -> [AvailInfo] -- ^ All exports + -> OccEnv Name -- ^ Default Methods + -> DocStructure +mkDocStructure mdl import_avails (Just export_list) _ _ _ = + mkDocStructureFromExportList mdl import_avails export_list +mkDocStructure _ _ Nothing rn_decls all_exports def_meths_env = + mkDocStructureFromDecls def_meths_env all_exports rn_decls + +-- TODO: +-- * Maybe remove items that export nothing? +-- * Combine sequences of DsiExports? +-- * Check the ordering of avails in DsiModExport +mkDocStructureFromExportList + :: Module -- ^ The current module + -> ImportAvails + -> [(LIE GhcRn, Avails)] -- ^ Explicit export list + -> DocStructure +mkDocStructureFromExportList mdl import_avails export_list = + toDocStructure . first unLoc <$> export_list + where + toDocStructure :: (IE GhcRn, Avails) -> DocStructureItem + toDocStructure = \case + (IEModuleContents _ lmn, avails) -> moduleExport (unLoc lmn) avails + (IEGroup _ level doc, _) -> DsiSectionHeading level (unLoc doc) + (IEDoc _ doc, _) -> DsiDocChunk (unLoc doc) + (IEDocNamed _ name, _) -> DsiNamedChunkRef name + (_, avails) -> DsiExports (nubAvails avails) + + moduleExport :: ModuleName -- Alias + -> Avails + -> DocStructureItem + moduleExport alias avails = + DsiModExport (nubSortNE orig_names) (nubAvails avails) + where + orig_names = M.findWithDefault aliasErr alias aliasMap + aliasErr = error $ "mkDocStructureFromExportList: " + ++ (moduleNameString . moduleName) mdl + ++ ": Can't find alias " ++ moduleNameString alias + nubSortNE = NonEmpty.fromList . + Set.toList . + Set.fromList . + NonEmpty.toList + + -- Map from aliases to true module names. + aliasMap :: Map ModuleName (NonEmpty ModuleName) + aliasMap = + M.fromListWith (<>) $ + (this_mdl_name, this_mdl_name :| []) + : (flip concatMap (moduleEnvToList imported) $ \(mdl, imvs) -> + [(imv_name imv, moduleName mdl :| []) | imv <- imvs]) + where + this_mdl_name = moduleName mdl + + imported :: ModuleEnv [ImportedModsVal] + imported = mapModuleEnv importedByUser (imp_mods import_avails) + +-- | Figure out the documentation structure by correlating +-- the module exports with the located declarations. +mkDocStructureFromDecls :: OccEnv Name -- ^ The default method environment + -> [AvailInfo] -- ^ All exports, unordered + -> HsGroup GhcRn + -> DocStructure +mkDocStructureFromDecls env all_exports decls = + map unLoc (sortLocated (docs ++ avails)) + where + avails :: [Located DocStructureItem] + avails = flip fmap all_exports $ \avail -> + case M.lookup (availName avail) name_locs of + Just loc -> L loc (DsiExports [avail]) + -- FIXME: This is just a workaround that we use when handling e.g. + -- associated data families like in the html-test Instances.hs. + Nothing -> noLoc (DsiExports [avail]) + -- Nothing -> panicDoc "mkDocStructureFromDecls: No loc found for" + -- (ppr avail) + + docs = mapMaybe structuralDoc (hs_docs decls) + + structuralDoc :: LDocDecl GhcRn + -> Maybe (Located DocStructureItem) + structuralDoc = \case + L loc (DocCommentNamed _name doc) -> + -- TODO: Is this correct? + -- NB: There is no export list where we could reference the named chunk. + Just (L (locA loc) (DsiDocChunk (unLoc doc))) + + L loc (DocGroup level doc) -> + Just (L (locA loc) (DsiSectionHeading level (unLoc doc))) + + _ -> Nothing + + name_locs = M.fromList (concatMap ldeclNames (ungroup decls)) + ldeclNames (L loc d) = zip (getMainDeclBinder env d) (repeat (locA loc)) + +-- | Extract named documentation chunks from the renamed declarations. +-- +-- If there is no explicit export list, we simply return an empty map +-- since there would be no way to link to a named chunk. +getNamedChunks :: Bool -- ^ Do we have an explicit export list? + -> HsGroup (GhcPass pass) + -> Map String (HsDoc (GhcPass pass)) +getNamedChunks True decls = + M.fromList $ flip mapMaybe (unLoc <$> hs_docs decls) $ \case + DocCommentNamed name doc -> Just (name, unLoc doc) + _ -> Nothing +getNamedChunks False _ = M.empty -- | Create decl and arg doc-maps by looping through the declarations. -- For each declaration, find its names, its subordinates, and its doc strings. -mkMaps :: [Name] - -> [(LHsDecl GhcRn, [HsDocString])] - -> (Map Name (HsDocString), Map Name (IntMap HsDocString)) -mkMaps instances decls = - ( f' (map (nubByName fst) decls') - , f (filterMapping (not . IM.null) args) +mkMaps :: OccEnv Name + -> [Name] + -> [(LHsDecl GhcRn, [HsDoc GhcRn])] + -> (UniqMap Name [HsDoc GhcRn], UniqMap Name (IntMap (HsDoc GhcRn))) +mkMaps env instances decls = + ( listsToMapWith (++) (map (nubByName fst) decls') + , listsToMapWith (<>) (filterMapping (not . IM.null) args) ) where (decls', args) = unzip (map mappings decls) - f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b - f = M.fromListWith (<>) . concat - - f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString - f' = M.fromListWith appendDocs . concat + listsToMapWith f = listToUniqMap_C f . concat filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] filterMapping p = map (filter (p . snd)) - mappings :: (LHsDecl GhcRn, [HsDocString]) - -> ( [(Name, HsDocString)] - , [(Name, IntMap HsDocString)] + mappings :: (LHsDecl GhcRn, [HsDoc GhcRn]) + -> ( [(Name, [HsDoc GhcRn])] + , [(Name, IntMap (HsDoc GhcRn))] ) - mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, docStrs) = + mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, doc) = (dm, am) where - doc = concatDocs docStrs args = declTypeDocs decl - subs :: [(Name, [HsDocString], IntMap HsDocString)] - subs = subordinates instanceMap decl + subs :: [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))] + subs = subordinates env instanceMap decl - (subDocs, subArgs) = - unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs) + (subNs, subDocs, subArgs) = + unzip3 subs ns = names l decl - subNs = [ n | (n, _, _) <- subs ] - dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs] + dm = [(n, d) | (n, d) <- zip ns (repeat doc) ++ zip subNs subDocs, not $ all (isEmptyDocString . hsDocString) d] am = [(n, args) | n <- ns] ++ zip subNs subArgs mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], []) @@ -124,7 +270,7 @@ mkMaps instances decls = names :: RealSrcSpan -> HsDecl GhcRn -> [Name] names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1]. - names _ decl = getMainDeclBinder decl + names _ decl = getMainDeclBinder env decl {- Note [1]: @@ -135,27 +281,37 @@ looking at GHC sources). We can assume that commented instances are user-written. This lets us relate Names (from ClsInsts) to comments (associated with InstDecls and DerivDecls). -} -getMainDeclBinder :: (Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p)) - => HsDecl (GhcPass p) -> [IdP (GhcPass p)] -getMainDeclBinder (TyClD _ d) = [tcdName d] -getMainDeclBinder (ValD _ d) = + +getMainDeclBinder + :: OccEnv Name -- ^ Default method environment for this module. See Note [default method Name] in GHC.Iface.Recomp + -> HsDecl GhcRn -> [Name] +getMainDeclBinder _ (TyClD _ d) = [tcdName d] +getMainDeclBinder _ (ValD _ d) = case collectHsBindBinders CollNoDictBinders d of [] -> [] (name:_) -> [name] -getMainDeclBinder (SigD _ d) = sigNameNoLoc d -getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] -getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] -getMainDeclBinder _ = [] - - -sigNameNoLoc :: forall pass. UnXRec pass => Sig pass -> [IdP pass] -sigNameNoLoc (TypeSig _ ns _) = map (unXRec @pass) ns -sigNameNoLoc (ClassOpSig _ _ ns _) = map (unXRec @pass) ns -sigNameNoLoc (PatSynSig _ ns _) = map (unXRec @pass) ns -sigNameNoLoc (SpecSig _ n _ _) = [unXRec @pass n] -sigNameNoLoc (InlineSig _ n _) = [unXRec @pass n] -sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @pass) ns -sigNameNoLoc _ = [] +getMainDeclBinder env (SigD _ d) = sigNameNoLoc env d +getMainDeclBinder _ (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinder _ (ForD _ (ForeignExport _ _ _ _)) = [] +getMainDeclBinder _ _ = [] + + +-- | The "OccEnv Name" is the default method environment for this module +-- Ultimately, the a special "defaultMethodOcc" name is used for +-- the signatures on bindings for default methods. Unfortunately, this +-- name isn't generated until typechecking, so it is not in the renamed AST. +-- We have to look it up from the 'OccEnv' parameter constructed from the typechecked +-- AST. +-- See also Note [default method Name] in GHC.Iface.Recomp +sigNameNoLoc :: forall a . (UnXRec a, HasOccName (IdP a)) => OccEnv (IdP a) -> Sig a -> [IdP a] +sigNameNoLoc _ (TypeSig _ ns _) = map (unXRec @a) ns +sigNameNoLoc _ (ClassOpSig _ False ns _) = map (unXRec @a) ns +sigNameNoLoc env (ClassOpSig _ True ns _) = mapMaybe (lookupOccEnv env . mkDefaultMethodOcc . occName) $ map (unXRec @a) ns +sigNameNoLoc _ (PatSynSig _ ns _) = map (unXRec @a) ns +sigNameNoLoc _ (SpecSig _ n _ _) = [unXRec @a n] +sigNameNoLoc _ (InlineSig _ n _) = [unXRec @a n] +sigNameNoLoc _ (FixSig _ (FixitySig _ ns _)) = map (unXRec @a) ns +sigNameNoLoc _ _ = [] -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the @@ -180,15 +336,21 @@ getInstLoc = \case -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data -- family of a type class. -subordinates :: Map RealSrcSpan Name +subordinates :: OccEnv Name -- ^ The default method environment + -> Map RealSrcSpan Name -> HsDecl GhcRn - -> [(Name, [HsDocString], IntMap HsDocString)] -subordinates instMap decl = case decl of - InstD _ (ClsInstD _ d) -> do - DataFamInstDecl { dfid_eqn = - FamEqn { feqn_tycon = L l _ - , feqn_rhs = defn }} <- unLoc <$> cid_datafam_insts d - [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn + -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))] +subordinates env instMap decl = case decl of + InstD _ (ClsInstD _ d) -> let + data_fams = do + DataFamInstDecl { dfid_eqn = + FamEqn { feqn_tycon = L l _ + , feqn_rhs = defn }} <- unLoc <$> cid_datafam_insts d + [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn + ty_fams = do + TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = L l _ } } <- unLoc <$> cid_tyfam_insts d + [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] + in data_fams ++ ty_fams InstD _ (DataFamInstD _ (DataFamInstDecl d)) -> dataSubs (feqn_rhs d) @@ -198,11 +360,11 @@ subordinates instMap decl = case decl of where classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd - , name <- getMainDeclBinder d, not (isValD d) + , name <- getMainDeclBinder env d, not (isValD d) ] dataSubs :: HsDataDefn GhcRn - -> [(Name, [HsDocString], IntMap HsDocString)] - dataSubs dd = constrs ++ fields ++ derivs + -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))] + dataSubs dd = constrs ++ fields ++ derivs where cons = map unLoc $ (dd_cons dd) constrs = [ ( unLoc cname @@ -220,13 +382,13 @@ subordinates instMap decl = case decl of dd_derivs dd , Just instName <- [lookupSrcSpan l instMap] ] - extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDocString)] + extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDoc GhcRn)] extract_deriv_clause_tys (L _ dct) = case dct of DctSingle _ ty -> maybeToList $ extract_deriv_ty ty DctMulti _ tys -> mapMaybe extract_deriv_ty tys - extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString) + extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDoc GhcRn) extract_deriv_ty (L l (HsSig{sig_body = L _ ty})) = case ty of -- deriving (C a {- ^ Doc comment -}) @@ -234,25 +396,25 @@ subordinates instMap decl = case decl of _ -> Nothing -- | Extract constructor argument docs from inside constructor decls. -conArgDocs :: ConDecl GhcRn -> IntMap HsDocString +conArgDocs :: ConDecl GhcRn -> IntMap (HsDoc GhcRn) conArgDocs (ConDeclH98{con_args = args}) = h98ConArgDocs args conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) = gadtConArgDocs args (unLoc res_ty) -h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap HsDocString +h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap (HsDoc GhcRn) h98ConArgDocs con_args = case con_args of PrefixCon _ args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1) , unLoc (hsScaledThing arg2) ] RecCon _ -> IM.empty -gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString +gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap (HsDoc GhcRn) gadtConArgDocs con_args res_ty = case con_args of PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty] RecConGADT _ _ -> con_arg_docs 1 [res_ty] -con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString +con_arg_docs :: Int -> [HsType GhcRn] -> IntMap (HsDoc GhcRn) con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..] where f n (HsDocTy _ _ lds) = Just (n, unLoc lds) @@ -265,7 +427,7 @@ isValD _ = False -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. -classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])] classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls where decls = docs ++ defs ++ sigs ++ ats @@ -275,7 +437,7 @@ classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ -- | Extract function argument docs from inside top-level decls. -declTypeDocs :: HsDecl GhcRn -> IntMap (HsDocString) +declTypeDocs :: HsDecl GhcRn -> IntMap (HsDoc GhcRn) declTypeDocs = \case SigD _ (TypeSig _ _ ty) -> sigTypeDocs (unLoc (dropWildCards ty)) SigD _ (ClassOpSig _ _ _ ty) -> sigTypeDocs (unLoc ty) @@ -296,7 +458,7 @@ nubByName f ns = go emptyNameSet ns y = f x -- | Extract function argument docs from inside types. -typeDocs :: HsType GhcRn -> IntMap HsDocString +typeDocs :: HsType GhcRn -> IntMap (HsDoc GhcRn) typeDocs = go 0 where go n = \case @@ -308,12 +470,12 @@ typeDocs = go 0 _ -> IM.empty -- | Extract function argument docs from inside types. -sigTypeDocs :: HsSigType GhcRn -> IntMap HsDocString +sigTypeDocs :: HsSigType GhcRn -> IntMap (HsDoc GhcRn) sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body) -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists. -topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])] topDecls = filterClasses . filterDecls . collectDocs . sortLocatedA . ungroup -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. @@ -340,14 +502,14 @@ ungroup group_ = -- | Collect docs and attach them to the right declarations. -- -- A declaration may have multiple doc strings attached to it. -collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])] +collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDoc p])] -- ^ This is an example. collectDocs = go [] Nothing where go docs mprev decls = case (decls, mprev) of - ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds - ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds - ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds + ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing) -> go (unLoc s:docs) Nothing ds + ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [unLoc s] Nothing ds + ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev) -> go (unLoc s:docs) mprev ds (d : ds, Nothing) -> go docs (Just d) ds (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds ([] , Nothing) -> [] @@ -401,14 +563,15 @@ extractTHDocs :: THDocs extractTHDocs docs = -- Split up docs into separate maps for each 'DocLoc' type ExtractedTHDocs - docHeader - (DeclDocMap (searchDocs decl)) - (ArgDocMap (searchDocs args)) - (DeclDocMap (searchDocs insts)) + { ethd_mod_header = docHeader + , ethd_decl_docs = searchDocs decl + , ethd_arg_docs = searchDocs args + , ethd_inst_docs = searchDocs insts + } where - docHeader :: Maybe HsDocString + docHeader :: Maybe (HsDoc GhcRn) docHeader - | ((_, s):_) <- filter isModDoc (M.toList docs) = Just (mkHsDocString s) + | ((_, s):_) <- filter isModDoc (M.toList docs) = Just s | otherwise = Nothing isModDoc (ModuleDoc, _) = True @@ -417,38 +580,40 @@ extractTHDocs docs = -- Folds over the docs, applying 'f' as the accumulating function. -- We use different accumulating functions to sift out the specific types of -- documentation - searchDocs :: Monoid a => (a -> (DocLoc, String) -> a) -> a - searchDocs f = foldl' f mempty $ M.toList docs + searchDocs :: (UniqMap Name a -> (DocLoc, HsDoc GhcRn) -> UniqMap Name a) -> UniqMap Name a + searchDocs f = foldl' f emptyUniqMap $ M.toList docs -- Pick out the declaration docs - decl acc ((DeclDoc name), s) = M.insert name (mkHsDocString s) acc + decl acc ((DeclDoc name), s) = addToUniqMap acc name s decl acc _ = acc -- Pick out the instance docs - insts acc ((InstDoc name), s) = M.insert name (mkHsDocString s) acc + insts acc ((InstDoc name), s) = addToUniqMap acc name s insts acc _ = acc -- Pick out the argument docs - args :: Map Name (IntMap HsDocString) - -> (DocLoc, String) - -> Map Name (IntMap HsDocString) + args :: UniqMap Name (IntMap (HsDoc GhcRn)) + -> (DocLoc, HsDoc GhcRn) + -> UniqMap Name (IntMap (HsDoc GhcRn)) args acc ((ArgDoc name i), s) = -- Insert the doc for the arg into the argument map for the function. This -- means we have to search to see if an map already exists for the -- function, and insert the new argument if it exists, or create a new map - let ds = mkHsDocString s - in M.insertWith (\_ m -> IM.insert i ds m) name (IM.singleton i ds) acc + addToUniqMap_C (\_ m -> IM.insert i s m) acc name (IM.singleton i s) args acc _ = acc -- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two -- maps with values for the same key merge the inner map as well. -- Left biased so @unionArgMaps a b@ prefers @a@ over @b@. -unionArgMaps :: Map Name (IntMap b) - -> Map Name (IntMap b) - -> Map Name (IntMap b) -unionArgMaps a b = M.foldlWithKey go b a + +unionArgMaps :: forall b . UniqMap Name (IntMap b) + -> UniqMap Name (IntMap b) + -> UniqMap Name (IntMap b) +unionArgMaps a b = nonDetFoldUniqMap go b a where - go acc n newArgMap - | Just oldArgMap <- M.lookup n acc = - M.insert n (newArgMap `IM.union` oldArgMap) acc - | otherwise = M.insert n newArgMap acc + go :: (Name, IntMap b) + -> UniqMap Name (IntMap b) -> UniqMap Name (IntMap b) + go (n, newArgMap) acc + | Just oldArgMap <- lookupUniqMap acc n = + addToUniqMap acc n (newArgMap `IM.union` oldArgMap) + | otherwise = addToUniqMap acc n newArgMap diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 60885ae7ee..73ad2a09b7 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -205,7 +205,7 @@ call and just recurse directly in to the subexpressions. -- These synonyms match those defined in compiler/GHC.hs type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] , Maybe [(LIE GhcRn, Avails)] - , Maybe LHsDocString ) + , Maybe (LHsDoc GhcRn) ) type TypecheckedSource = LHsBinds GhcTc @@ -316,12 +316,13 @@ getCompressedAsts ts rs top_ev_binds insts tcs = enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] -> HieASTs Type -enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = +enrichHie ts (hsGrp, imports, exports, docs) ev_bs insts tcs = runIdentity $ flip evalStateT initState $ flip runReaderT SourceInfo $ do tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts rasts <- processGrp hsGrp imps <- toHie $ filter (not . ideclImplicit . unLoc) imports exps <- toHie $ fmap (map $ IEC Export . fst) exports + docs <- toHie docs -- Add Instance bindings forM_ insts $ \i -> addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing) @@ -341,6 +342,7 @@ enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = , rasts , imps , exps + , docs ] modulify (HiePath file) xs' = do @@ -387,6 +389,7 @@ enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = , toHie $ hs_warnds grp , toHie $ hs_annds grp , toHie $ hs_ruleds grp + , toHie $ hs_docs grp ] getRealSpanA :: SrcSpanAnn' ann -> Maybe Span @@ -1596,7 +1599,8 @@ instance ToHie a => ToHie (HsScaled GhcRn a) where instance ToHie (LocatedA (ConDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs - , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } -> + , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ + , con_doc = doc} -> [ toHie $ map (C (Decl ConDec $ getRealSpanA span)) names , case outer_bndrs of HsOuterImplicit{hso_ximplicit = imp_vars} -> @@ -1607,6 +1611,7 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where , toHie ctx , toHie args , toHie typ + , toHie doc ] where rhsScope = combineScopes argsScope tyScope @@ -1617,11 +1622,13 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where tyScope = mkLScopeA typ resScope = ResolvedScopes [ctxScope, rhsScope] ConDeclH98 { con_name = name, con_ex_tvs = qvars - , con_mb_cxt = ctx, con_args = dets } -> + , con_mb_cxt = ctx, con_args = dets + , con_doc = doc} -> [ toHie $ C (Decl ConDec $ getRealSpan (locA span)) name , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars , toHie ctx , toHie dets + , toHie doc ] where rhsScope = combineScopes ctxScope argsScope @@ -1780,8 +1787,9 @@ instance ToHie (LocatedA (HsType GhcRn)) where HsSpliceTy _ a -> [ toHie $ L span a ] - HsDocTy _ a _ -> + HsDocTy _ a doc -> [ toHie a + , toHie doc ] HsBangTy _ _ ty -> [ toHie ty @@ -1832,9 +1840,10 @@ instance ToHie (LocatedC [LocatedA (HsType GhcRn)]) where instance ToHie (LocatedA (ConDeclField GhcRn)) where toHie (L span field) = concatM $ makeNode field (locA span) : case field of - ConDeclField _ fields typ _ -> + ConDeclField _ fields typ doc -> [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields , toHie typ + , toHie doc ] instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where @@ -2088,8 +2097,8 @@ instance ToHie (IEContext (LocatedA (IE GhcRn))) where IEModuleContents _ n -> [ toHie $ IEC c n ] - IEGroup _ _ _ -> [] - IEDoc _ _ -> [] + IEGroup _ _ d -> [toHie d] + IEDoc _ d -> [toHie d] IEDocNamed _ _ -> [] instance ToHie (IEContext (LIEWrappedName Name)) where @@ -2109,3 +2118,13 @@ instance ToHie (IEContext (Located FieldLabel)) where [ makeNode lbl span , toHie $ C (IEThing c) $ L span (flSelector lbl) ] + +instance ToHie (LocatedA (DocDecl GhcRn)) where + toHie (L span d) = concatM $ makeNodeA d span : case d of + DocCommentNext d -> [ toHie d ] + DocCommentPrev d -> [ toHie d ] + DocCommentNamed _ d -> [ toHie d ] + DocGroup _ d -> [ toHie d ] + +instance ToHie (LHsDoc GhcRn) where + toHie (L span d@(WithHsDocIdentifiers _ ids)) = concatM $ makeNode d span : [toHie $ map (C Use) ids] diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 0055cea807..18554fdc50 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -21,7 +21,7 @@ module GHC.Iface.Load ( -- RnM/TcM functions loadModuleInterface, loadModuleInterfaces, loadSrcInterface, loadSrcInterface_maybe, - loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule, + loadInterfaceForName, loadInterfaceForModule, -- IfM functions loadInterface, @@ -349,15 +349,6 @@ loadInterfaceForName doc name ; assertPpr (isExternalName name) (ppr name) $ initIfaceTcRn $ loadSysInterface doc (nameModule name) } --- | Only loads the interface for external non-local names. -loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface) -loadInterfaceForNameMaybe doc name - = do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod name || not (isExternalName name) - then return Nothing - else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name)) - } - -- | Loads the interface for a given Module. loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface loadInterfaceForModule doc m @@ -1025,7 +1016,7 @@ ghcPrimIface mi_decls = [], mi_fixities = fixities, mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities }, - mi_decl_docs = ghcPrimDeclDocs -- See Note [GHC.Prim Docs] + mi_docs = Just ghcPrimDeclDocs -- See Note [GHC.Prim Docs] } where empty_iface = emptyFullModIface gHC_PRIM @@ -1142,9 +1133,7 @@ pprModIface unit_state iface@ModIface{ mi_final_exts = exts } , pprTrustInfo (mi_trust iface) , pprTrustPkg (mi_trust_pkg iface) , vcat (map ppr (mi_complete_matches iface)) - , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface)) - , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface)) - , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface)) + , text "docs:" $$ nest 2 (ppr (mi_docs iface)) , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface)) ] where @@ -1209,13 +1198,13 @@ pprTrustInfo trust = text "trusted:" <+> ppr trust pprTrustPkg :: Bool -> SDoc pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg -instance Outputable Warnings where +instance Outputable (Warnings pass) where ppr = pprWarns -pprWarns :: Warnings -> SDoc +pprWarns :: Warnings pass -> SDoc pprWarns NoWarnings = Outputable.empty pprWarns (WarnAll txt) = text "Warn all" <+> ppr txt -pprWarns (WarnSome prs) = text "Warnings" +pprWarns (WarnSome prs) = text "Warnings:" <+> vcat (map pprWarning prs) where pprWarning (name, txt) = ppr name <+> ppr txt diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 19739ff3e3..7cf782a18d 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -125,12 +125,10 @@ mkPartialIface hsc_env mod_details mod_summary , mg_hpc_info = hpc_info , mg_safe_haskell = safe_mode , mg_trust_pkg = self_trust - , mg_doc_hdr = doc_hdr - , mg_decl_docs = decl_docs - , mg_arg_docs = arg_docs + , mg_docs = docs } = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust - safe_mode usages doc_hdr decl_docs arg_docs mod_summary mod_details + safe_mode usages docs mod_summary mod_details -- | Fully instantiate an interface. Adds fingerprints and potentially code -- generator produced information. @@ -222,34 +220,32 @@ mkIfaceTc hsc_env safe_mode mod_details mod_summary usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files merged needed_links needed_pkgs - (doc_hdr', doc_map, arg_map) <- extractDocs tc_result + docs <- extractDocs (ms_hspp_opts mod_summary) tc_result let partial_iface = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info (imp_trust_own_pkg imports) safe_mode usages - doc_hdr' doc_map arg_map mod_summary + docs mod_summary mod_details mkFullIface hsc_env partial_iface Nothing mkIface_ :: HscEnv -> Module -> HscSource -> Bool -> Dependencies -> GlobalRdrEnv - -> NameEnv FixItem -> Warnings -> HpcInfo + -> NameEnv FixItem -> Warnings GhcRn -> HpcInfo -> Bool -> SafeHaskellMode -> [Usage] - -> Maybe HsDocString - -> DeclDocMap - -> ArgDocMap + -> Maybe Docs -> ModSummary -> ModDetails -> PartialModIface mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env src_warns hpc_info pkg_trust_req safe_mode usages - doc_hdr decl_docs arg_docs mod_summary + docs mod_summary ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, @@ -322,9 +318,7 @@ mkIface_ hsc_env mi_trust = trust_info, mi_trust_pkg = pkg_trust_req, mi_complete_matches = icomplete_matches, - mi_doc_hdr = doc_hdr, - mi_decl_docs = decl_docs, - mi_arg_docs = arg_docs, + mi_docs = docs, mi_final_exts = (), mi_ext_fields = emptyExtensibleFields, mi_src_hash = ms_hs_hash mod_summary diff --git a/compiler/GHC/Parser.hs-boot b/compiler/GHC/Parser.hs-boot new file mode 100644 index 0000000000..6d5cb4c68f --- /dev/null +++ b/compiler/GHC/Parser.hs-boot @@ -0,0 +1,7 @@ +module GHC.Parser where + +import GHC.Types.Name.Reader (RdrName) +import GHC.Parser.Lexer (P) +import GHC.Parser.Annotation (LocatedN) + +parseIdentifier :: P (LocatedN RdrName) diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index ce1c48b99d..418d67dc67 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -83,6 +83,7 @@ import GHC.Core.DataCon ( DataCon, dataConName ) import GHC.Parser.PostProcess import GHC.Parser.PostProcess.Haddock import GHC.Parser.Lexer +import GHC.Parser.HaddockLex import GHC.Parser.Annotation import GHC.Parser.Errors.Types import GHC.Parser.Errors.Ppr () @@ -902,12 +903,12 @@ missing_module_keyword :: { () } implicit_top :: { () } : {- empty -} {% pushModuleContext } -maybemodwarning :: { Maybe (LocatedP WarningTxt) } +maybemodwarning :: { Maybe (LocatedP (WarningTxt GhcPs)) } : '{-# DEPRECATED' strings '#-}' - {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (snd $ unLoc $2)) + {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2)) (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) } | '{-# WARNING' strings '#-}' - {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt (sL1 $1 $ getWARNING_PRAGs $1) (snd $ unLoc $2)) + {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2)) (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2))} | {- empty -} { Nothing } @@ -1940,7 +1941,7 @@ warning :: { OrdList (LWarnDecl GhcPs) } : namelist strings {% fmap unitOL $ acsA (\cs -> sLL $1 $> (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1) - (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) } + (WarningTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) } deprecations :: { OrdList (LWarnDecl GhcPs) } : deprecations ';' deprecation @@ -1963,7 +1964,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } deprecation :: { OrdList (LWarnDecl GhcPs) } : namelist strings {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1) - (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) } + (DeprecatedTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) } strings :: { Located ([AddEpAnn],[Located StringLiteral]) } : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) } @@ -3962,6 +3963,9 @@ getSCC lt = do let s = getSTRING lt then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC else return s +stringLiteralToHsDocWst :: Located StringLiteral -> Located (WithHsDocIdentifiers StringLiteral GhcPs) +stringLiteralToHsDocWst = lexStringLiteral parseIdentifier + -- Utilities for combining source spans comb2 :: Located a -> Located b -> SrcSpan comb2 a b = a `seq` b `seq` combineLocs a b diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index 1f48615aec..dd0cdd3123 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -93,6 +93,7 @@ import Data.Semigroup import GHC.Data.FastString import GHC.Types.Name import GHC.Types.SrcLoc +import GHC.Hs.DocString import GHC.Utils.Binary import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic @@ -358,14 +359,11 @@ data EpaComment = -- and the start of this location is used for the spacing when -- exact printing the comment. } - deriving (Eq, Ord, Data, Show) + deriving (Eq, Data, Show) data EpaCommentTok = -- Documentation annotations - EpaDocCommentNext String -- ^ something beginning '-- |' - | EpaDocCommentPrev String -- ^ something beginning '-- ^' - | EpaDocCommentNamed String -- ^ something beginning '-- $' - | EpaDocSection Int String -- ^ a section heading + EpaDocComment HsDocString -- ^ a docstring that can be pretty printed using pprHsDocString | EpaDocOptions String -- ^ doc options (prune, ignore-exports, etc) | EpaLineComment String -- ^ comment starting by "--" | EpaBlockComment String -- ^ comment in {- -} @@ -376,7 +374,7 @@ data EpaCommentTok = -- should be removed in favour of capturing it in the location for -- 'Located HsModule' in the parser. - deriving (Eq, Ord, Data, Show) + deriving (Eq, Data, Show) -- Note: these are based on the Token versions, but the Token type is -- defined in GHC.Parser.Lexer and bringing it in here would create a loop @@ -407,12 +405,12 @@ data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq) -- sort the relative order. data EpaLocation = EpaSpan !RealSrcSpan | EpaDelta !DeltaPos ![LEpaComment] - deriving (Data,Eq,Ord) + deriving (Data,Eq) -- | Tokens embedded in the AST have an EpaLocation, unless they come from -- generated code (e.g. by TH). data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation - deriving (Data,Eq,Ord) + deriving (Data,Eq) -- | Spacing between output items when exact printing. It captures -- the spacing from the current print position on the page to the @@ -460,9 +458,6 @@ instance Outputable EpaLocation where instance Outputable AddEpAnn where ppr (AddEpAnn kw ss) = text "AddEpAnn" <+> ppr kw <+> ppr ss -instance Ord AddEpAnn where - compare (AddEpAnn kw1 loc1) (AddEpAnn kw2 loc2) = compare (loc1, kw1) (loc2,kw2) - -- --------------------------------------------------------------------- -- | The exact print annotations (EPAs) are kept in the HsSyn AST for @@ -640,7 +635,7 @@ data TrailingAnn = AddSemiAnn EpaLocation -- ^ Trailing ';' | AddCommaAnn EpaLocation -- ^ Trailing ',' | AddVbarAnn EpaLocation -- ^ Trailing '|' - deriving (Data, Eq, Ord) + deriving (Data, Eq) instance Outputable TrailingAnn where ppr (AddSemiAnn ss) = text "AddSemiAnn" <+> ppr ss diff --git a/compiler/GHC/Parser/HaddockLex.x b/compiler/GHC/Parser/HaddockLex.x new file mode 100644 index 0000000000..e215769f9e --- /dev/null +++ b/compiler/GHC/Parser/HaddockLex.x @@ -0,0 +1,201 @@ +{ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +module GHC.Parser.HaddockLex (lexHsDoc, lexStringLiteral) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Hs.Doc +import GHC.Parser.Lexer +import GHC.Parser.Annotation +import GHC.Types.SrcLoc +import GHC.Types.SourceText +import GHC.Data.StringBuffer +import qualified GHC.Data.Strict as Strict +import GHC.Types.Name.Reader +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Utils.Encoding +import GHC.Hs.Extension + +import qualified GHC.Data.EnumSet as EnumSet + +import Data.Maybe +import Data.Word + +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS + +import qualified GHC.LanguageExtensions as LangExt +} + +-- ----------------------------------------------------------------------------- +-- Alex "Character set macros" +-- Copied from GHC/Parser/Lexer.x + +-- NB: The logic behind these definitions is also reflected in "GHC.Utils.Lexeme" +-- Any changes here should likely be reflected there. +$unispace = \x05 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$nl = [\n\r\f] +$whitechar = [$nl\v\ $unispace] +$white_no_nl = $whitechar # \n -- TODO #8424 +$tab = \t + +$ascdigit = 0-9 +$unidigit = \x03 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$decdigit = $ascdigit -- exactly $ascdigit, no more no less. +$digit = [$ascdigit $unidigit] + +$special = [\(\)\,\;\[\]\`\{\}] +$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:] +$unisymbol = \x04 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$symbol = [$ascsymbol $unisymbol] # [$special \_\"\'] + +$unilarge = \x01 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$asclarge = [A-Z] +$large = [$asclarge $unilarge] + +$unismall = \x02 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$ascsmall = [a-z] +$small = [$ascsmall $unismall \_] + +$uniidchar = \x07 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$idchar = [$small $large $digit $uniidchar \'] + +$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$graphic = [$small $large $symbol $digit $idchar $special $unigraphic \"\'] + +$alpha = [$small $large] + +-- The character sets marked "TODO" are mostly overly inclusive +-- and should be defined more precisely once alex has better +-- support for unicode character sets (see +-- https://github.com/simonmar/alex/issues/126). + +@id = $alpha $idchar* \#* | $symbol+ +@modname = $large $idchar* +@qualid = (@modname \.)* @id + +:- + \' @qualid \' | \` @qualid \` { getIdentifier 1 } + \'\` @qualid \`\' | \'\( @qualid \)\' | \`\( @qualid \)\` { getIdentifier 2 } + [. \n] ; + +{ +data AlexInput = AlexInput + { alexInput_position :: !RealSrcLoc + , alexInput_string :: !ByteString + } + +-- NB: As long as we don't use a left-context we don't need to track the +-- previous input character. +alexInputPrevChar :: AlexInput -> Word8 +alexInputPrevChar = error "Left-context not supported" + +alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) +alexGetByte (AlexInput p s) = case utf8UnconsByteString s of + Nothing -> Nothing + Just (c,bs) -> Just (adjustChar c, AlexInput (advanceSrcLoc p c) bs) + +alexScanTokens :: RealSrcLoc -> ByteString -> [(RealSrcSpan, ByteString)] +alexScanTokens start str0 = go (AlexInput start str0) + where go inp@(AlexInput pos str) = + case alexScan inp 0 of + AlexSkip inp' _ln -> go inp' + AlexToken inp'@(AlexInput _ str') _ act -> act pos (BS.length str - BS.length str') str : go inp' + AlexEOF -> [] + AlexError (AlexInput p _) -> error $ "lexical error at " ++ show p + +-------------------------------------------------------------------------------- + +-- | Extract identifier from Alex state. +getIdentifier :: Int -- ^ adornment length + -> RealSrcLoc + -> Int + -- ^ Token length + -> ByteString + -- ^ The remaining input beginning with the found token + -> (RealSrcSpan, ByteString) +getIdentifier !i !loc0 !len0 !s0 = + (mkRealSrcSpan loc1 loc2, ident) + where + (adornment, s1) = BS.splitAt i s0 + ident = BS.take (len0 - 2*i) s1 + loc1 = advanceSrcLocBS loc0 adornment + loc2 = advanceSrcLocBS loc1 ident + +advanceSrcLocBS :: RealSrcLoc -> ByteString -> RealSrcLoc +advanceSrcLocBS !loc bs = case utf8UnconsByteString bs of + Nothing -> loc + Just (c, bs') -> advanceSrcLocBS (advanceSrcLoc loc c) bs' + +-- | Lex 'StringLiteral' for warning messages +lexStringLiteral :: P (LocatedN RdrName) -- ^ A precise identifier parser + -> Located StringLiteral + -> Located (WithHsDocIdentifiers StringLiteral GhcPs) +lexStringLiteral identParser (L l sl@(StringLiteral _ fs _)) + = L l (WithHsDocIdentifiers sl idents) + where + bs = bytesFS fs + + idents = mapMaybe (uncurry (validateIdentWith identParser)) plausibleIdents + + plausibleIdents :: [(SrcSpan,ByteString)] + plausibleIdents = case l of + RealSrcSpan span _ -> [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs] + UnhelpfulSpan reason -> [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc bs] + + fakeLoc = mkRealSrcLoc (mkFastString "") 0 0 + +-- | Lex identifiers from a docstring. +lexHsDoc :: P (LocatedN RdrName) -- ^ A precise identifier parser + -> HsDocString + -> HsDoc GhcPs +lexHsDoc identParser doc = + WithHsDocIdentifiers doc idents + where + docStrings = docStringChunks doc + idents = concat [mapMaybe maybeDocIdentifier (plausibleIdents doc) | doc <- docStrings] + + maybeDocIdentifier :: (SrcSpan, ByteString) -> Maybe (Located RdrName) + maybeDocIdentifier = uncurry (validateIdentWith identParser) + + plausibleIdents :: LHsDocStringChunk -> [(SrcSpan,ByteString)] + plausibleIdents (L (RealSrcSpan span _) (HsDocStringChunk s)) + = [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) s] + plausibleIdents (L (UnhelpfulSpan reason) (HsDocStringChunk s)) + = [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason + + fakeLoc = mkRealSrcLoc (mkFastString "") 0 0 + +validateIdentWith :: P (LocatedN RdrName) -> SrcSpan -> ByteString -> Maybe (Located RdrName) +validateIdentWith identParser mloc str0 = + let -- These ParserFlags should be as "inclusive" as possible, allowing + -- identifiers defined with any language extension. + pflags = mkParserOpts + (EnumSet.fromList [LangExt.MagicHash]) + dopts + [] + False False False False + dopts = DiagOpts + { diag_warning_flags = EnumSet.empty + , diag_fatal_warning_flags = EnumSet.empty + , diag_warn_is_error = False + , diag_reverse_errors = False + , diag_max_errors = Nothing + , diag_ppr_ctx = defaultSDocContext + } + buffer = stringBufferFromByteString str0 + realSrcLc = case mloc of + RealSrcSpan loc _ -> realSrcSpanStart loc + UnhelpfulSpan _ -> mkRealSrcLoc (mkFastString "") 0 0 + pstate = initParserState pflags buffer realSrcLc + in case unP identParser pstate of + POk _ name -> Just $ case mloc of + RealSrcSpan _ _ -> reLoc name + UnhelpfulSpan _ -> L mloc (unLoc name) -- Preserve the original reason + _ -> Nothing +} diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index cb8a5c334e..87f20b5c9c 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -301,13 +300,10 @@ getOptions' opts toks isComment :: Token -> Bool isComment c = case c of - (ITlineComment {}) -> True - (ITblockComment {}) -> True - (ITdocCommentNext {}) -> True - (ITdocCommentPrev {}) -> True - (ITdocCommentNamed {}) -> True - (ITdocSection {}) -> True - _ -> False + (ITlineComment {}) -> True + (ITblockComment {}) -> True + (ITdocComment {}) -> True + _ -> False toArgs :: RealSrcLoc -> String -> Either String -- Error diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 7d7d157d2b..02717c7dae 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -76,6 +76,7 @@ module GHC.Parser.Lexer ( commentToAnnotation, HdkComment(..), warnopt, + adjustChar, addPsMessage ) where @@ -87,6 +88,8 @@ import Control.Monad import Control.Applicative import Data.Char import Data.List (stripPrefix, isInfixOf, partition) +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Word import Debug.Trace (trace) @@ -134,34 +137,34 @@ import GHC.Parser.Errors.Ppr () -- NB: The logic behind these definitions is also reflected in "GHC.Utils.Lexeme" -- Any changes here should likely be reflected there. -$unispace = \x05 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$unispace = \x05 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $nl = [\n\r\f] $whitechar = [$nl\v\ $unispace] $white_no_nl = $whitechar # \n -- TODO #8424 $tab = \t $ascdigit = 0-9 -$unidigit = \x03 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$unidigit = \x03 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $decdigit = $ascdigit -- exactly $ascdigit, no more no less. $digit = [$ascdigit $unidigit] $special = [\(\)\,\;\[\]\`\{\}] $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:] -$unisymbol = \x04 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$unisymbol = \x04 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $symbol = [$ascsymbol $unisymbol] # [$special \_\"\'] -$unilarge = \x01 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$unilarge = \x01 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $asclarge = [A-Z] $large = [$asclarge $unilarge] -$unismall = \x02 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$unismall = \x02 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $ascsmall = [a-z] $small = [$ascsmall $unismall \_] -$uniidchar = \x07 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$uniidchar = \x07 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $idchar = [$small $large $digit $uniidchar \'] -$unigraphic = \x06 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $graphic = [$small $large $symbol $digit $idchar $special $unigraphic \"\'] $binit = 0-1 @@ -230,7 +233,7 @@ $tab { warnTab } -- are). We also rule out nested Haddock comments, if the -haddock flag is -- set. -"{-" / { isNormalComment } { nested_comment lexToken } +"{-" / { isNormalComment } { nested_comment } -- Single-line comments are a bit tricky. Haskell 98 says that two or -- more dashes followed by a symbol should be parsed as a varsym, so we @@ -364,12 +367,12 @@ $tab { warnTab } <0> { -- In the "0" mode we ignore these pragmas "{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags } - { nested_comment lexToken } + { nested_comment } } <0,option_prags> { "{-#" { warnThen PsWarnUnrecognisedPragma - (nested_comment lexToken) } + (nested_comment ) } } -- '0' state: ordinary lexemes @@ -883,13 +886,11 @@ data Token | ITeof -- ^ end of file token -- Documentation annotations. See Note [PsSpan in Comments] - | ITdocCommentNext String PsSpan -- ^ something beginning @-- |@ - | ITdocCommentPrev String PsSpan -- ^ something beginning @-- ^@ - | ITdocCommentNamed String PsSpan -- ^ something beginning @-- $@ - | ITdocSection Int String PsSpan -- ^ a section heading - | ITdocOptions String PsSpan -- ^ doc options (prune, ignore-exports, etc) - | ITlineComment String PsSpan -- ^ comment starting by "--" - | ITblockComment String PsSpan -- ^ comment in {- -} + | ITdocComment HsDocString PsSpan -- ^ The HsDocString contains more details about what + -- this is and how to pretty print it + | ITdocOptions String PsSpan -- ^ doc options (prune, ignore-exports, etc) + | ITlineComment String PsSpan -- ^ comment starting by "--" + | ITblockComment String PsSpan -- ^ comment in {- -} deriving Show @@ -1280,16 +1281,23 @@ alexOrPred p1 p2 userState in1 len in2 = p1 userState in1 len in2 || p2 userState in1 len in2 multiline_doc_comment :: Action -multiline_doc_comment span buf _len = withLexedDocType (worker "") +multiline_doc_comment span buf _len = {-# SCC "multiline_doc_comment" #-} withLexedDocType worker where - worker commentAcc input docType checkNextLine = case alexGetChar' input of - Just ('\n', input') - | checkNextLine -> case checkIfCommentLine input' of - Just input -> worker ('\n':commentAcc) input docType checkNextLine - Nothing -> docCommentEnd input commentAcc docType buf span - | otherwise -> docCommentEnd input commentAcc docType buf span - Just (c, input) -> worker (c:commentAcc) input docType checkNextLine - Nothing -> docCommentEnd input commentAcc docType buf span + worker input@(AI start_loc _) docType checkNextLine = go start_loc "" [] input + where + go start_loc curLine prevLines input@(AI end_loc _) = case alexGetChar' input of + Just ('\n', input') + | checkNextLine -> case checkIfCommentLine input' of + Just input@(AI next_start _) -> go next_start "" (locatedLine : prevLines) input -- Start a new line + Nothing -> endComment + | otherwise -> endComment + Just (c, input) -> go start_loc (c:curLine) prevLines input + Nothing -> endComment + where + lineSpan = mkSrcSpanPs $ mkPsSpan start_loc end_loc + locatedLine = L lineSpan (mkHsDocStringChunk $ reverse curLine) + commentLines = NE.reverse $ locatedLine :| prevLines + endComment = docCommentEnd input (docType (\dec -> MultiLineDocString dec commentLines)) buf span -- Check if the next line of input belongs to this doc comment as well. -- A doc comment continues onto the next line when the following @@ -1331,15 +1339,43 @@ lineCommentToken span buf len = do nested comments require traversing by hand, they can't be parsed using regular expressions. -} -nested_comment :: P (PsLocated Token) -> Action -nested_comment cont span buf len = do +nested_comment :: Action +nested_comment span buf len = {-# SCC "nested_comment" #-} do + l <- getLastLocComment + let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span input <- getInput - go (reverse $ lexemeToString buf len) (1::Int) input + -- Include decorator in comment + let start_decorator = reverse $ lexemeToString buf len + nested_comment_logic endComment start_decorator input span + +nested_doc_comment :: Action +nested_doc_comment span buf _len = {-# SCC "nested_doc_comment" #-} withLexedDocType worker + where + worker input docType _checkNextLine = nested_comment_logic endComment "" input span + where + endComment input lcomment + = docCommentEnd input (docType (\d -> NestedDocString d (mkHsDocStringChunk . dropTrailingDec <$> lcomment))) buf span + + dropTrailingDec [] = [] + dropTrailingDec "-}" = "" + dropTrailingDec (x:xs) = x:dropTrailingDec xs + +{-# INLINE nested_comment_logic #-} +-- | Includes the trailing '-}' decorators +-- drop the last two elements with the callback if you don't want them to be included +nested_comment_logic + :: (AlexInput -> Located String -> P (PsLocated Token)) -- ^ Continuation that gets the rest of the input and the lexed comment + -> String -- ^ starting value for accumulator (reversed) - When we want to include a decorator '{-' in the comment + -> AlexInput + -> PsSpan + -> P (PsLocated Token) +nested_comment_logic endComment commentAcc input span = go commentAcc (1::Int) input where - go commentAcc 0 input = do - l <- getLastLocComment - let finalizeComment str = (Nothing, ITblockComment str l) - commentEnd cont input commentAcc finalizeComment buf span + go commentAcc 0 input@(AI end_loc _) = do + let comment = reverse commentAcc + cspan = mkSrcSpanPs $ mkPsSpan (psSpanStart span) end_loc + lcomment = L cspan comment + endComment input lcomment go commentAcc n input = case alexGetChar' input of Nothing -> errBrace input (psRealSpan span) Just ('-',input) -> case alexGetChar' input of @@ -1358,31 +1394,6 @@ nested_comment cont span buf len = do Just (_,_) -> go ('\n':commentAcc) n input Just (c,input) -> go (c:commentAcc) n input -nested_doc_comment :: Action -nested_doc_comment span buf _len = withLexedDocType (go "") - where - go commentAcc input docType _ = case alexGetChar' input of - Nothing -> errBrace input (psRealSpan span) - Just ('-',input) -> case alexGetChar' input of - Nothing -> errBrace input (psRealSpan span) - Just ('\125',input) -> - docCommentEnd input commentAcc docType buf span - Just (_,_) -> go ('-':commentAcc) input docType False - Just ('\123', input) -> case alexGetChar' input of - Nothing -> errBrace input (psRealSpan span) - Just ('-',input) -> do - setInput input - let cont = do input <- getInput; go commentAcc input docType False - nested_comment cont span buf _len - Just (_,_) -> go ('\123':commentAcc) input docType False - -- See Note [Nested comment line pragmas] - Just ('\n',input) -> case alexGetChar' input of - Nothing -> errBrace input (psRealSpan span) - Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input - go (parsedAcc ++ '\n':commentAcc) input docType False - Just (_,_) -> go ('\n':commentAcc) input docType False - Just (c,input) -> go (c:commentAcc) input docType False - -- See Note [Nested comment line pragmas] parseNestedPragma :: AlexInput -> P (String,AlexInput) parseNestedPragma input@(AI _ buf) = do @@ -1429,7 +1440,8 @@ return control to parseNestedPragma by returning the ITcomment_line_prag token. See #314 for more background on the bug this fixes. -} -withLexedDocType :: (AlexInput -> (String -> (HdkComment, Token)) -> Bool -> P (PsLocated Token)) +{-# INLINE withLexedDocType #-} +withLexedDocType :: (AlexInput -> ((HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)) -> Bool -> P (PsLocated Token)) -> P (PsLocated Token) withLexedDocType lexDocComment = do input@(AI _ buf) <- getInput @@ -1439,7 +1451,9 @@ withLexedDocType lexDocComment = do -- line of input might also belong to this doc comment. '|' -> lexDocComment input (mkHdkCommentNext l) True '^' -> lexDocComment input (mkHdkCommentPrev l) True - '$' -> lexDocComment input (mkHdkCommentNamed l) True + '$' -> case lexDocName input of + Nothing -> do setInput input; lexToken -- eof reached, lex it normally + Just (name, input) -> lexDocComment input (mkHdkCommentNamed l name) True '*' -> lexDocSection l 1 input _ -> panic "withLexedDocType: Bad doc type" where @@ -1448,18 +1462,28 @@ withLexedDocType lexDocComment = do Just (_, _) -> lexDocComment input (mkHdkCommentSection l n) False Nothing -> do setInput input; lexToken -- eof reached, lex it normally -mkHdkCommentNext, mkHdkCommentPrev :: PsSpan -> String -> (HdkComment, Token) -mkHdkCommentNext loc str = (HdkCommentNext (mkHsDocString str), ITdocCommentNext str loc) -mkHdkCommentPrev loc str = (HdkCommentPrev (mkHsDocString str), ITdocCommentPrev str loc) + lexDocName :: AlexInput -> Maybe (String, AlexInput) + lexDocName = go "" + where + go acc input = case alexGetChar' input of + Just (c, input') + | isSpace c -> Just (reverse acc, input) + | otherwise -> go (c:acc) input' + Nothing -> Nothing + +mkHdkCommentNext, mkHdkCommentPrev :: PsSpan -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) +mkHdkCommentNext loc mkDS = (HdkCommentNext ds,ITdocComment ds loc) + where ds = mkDS HsDocStringNext +mkHdkCommentPrev loc mkDS = (HdkCommentPrev ds,ITdocComment ds loc) + where ds = mkDS HsDocStringPrevious -mkHdkCommentNamed :: PsSpan -> String -> (HdkComment, Token) -mkHdkCommentNamed loc str = - let (name, rest) = break isSpace str - in (HdkCommentNamed name (mkHsDocString rest), ITdocCommentNamed str loc) +mkHdkCommentNamed :: PsSpan -> String -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) +mkHdkCommentNamed loc name mkDS = (HdkCommentNamed name ds, ITdocComment ds loc) + where ds = mkDS (HsDocStringNamed name) -mkHdkCommentSection :: PsSpan -> Int -> String -> (HdkComment, Token) -mkHdkCommentSection loc n str = - (HdkCommentSection n (mkHsDocString str), ITdocSection n str loc) +mkHdkCommentSection :: PsSpan -> Int -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) +mkHdkCommentSection loc n mkDS = (HdkCommentSection n ds, ITdocComment ds loc) + where ds = mkDS (HsDocStringGroup n) -- RULES pragmas turn on the forall and '.' keywords, and we turn them -- off again at the end of the pragma. @@ -1503,34 +1527,30 @@ endPrag span _buf _len = do -- it writes the wrong token length to the parser state. This function is -- called afterwards, so it can just update the state. +{-# INLINE commentEnd #-} commentEnd :: P (PsLocated Token) -> AlexInput - -> String - -> (String -> (Maybe HdkComment, Token)) + -> (Maybe HdkComment, Token) -> StringBuffer -> PsSpan -> P (PsLocated Token) -commentEnd cont input commentAcc finalizeComment buf span = do +commentEnd cont input (m_hdk_comment, hdk_token) buf span = do setInput input let (AI loc nextBuf) = input - comment = reverse commentAcc span' = mkPsSpan (psSpanStart span) loc last_len = byteDiff buf nextBuf span `seq` setLastToken span' last_len - let (m_hdk_comment, hdk_token) = finalizeComment comment whenIsJust m_hdk_comment $ \hdk_comment -> P $ \s -> POk (s {hdk_comments = hdk_comments s `snocOL` L span' hdk_comment}) () b <- getBit RawTokenStreamBit if b then return (L span' hdk_token) else cont -docCommentEnd :: AlexInput -> String -> (String -> (HdkComment, Token)) -> StringBuffer -> +{-# INLINE docCommentEnd #-} +docCommentEnd :: AlexInput -> (HdkComment, Token) -> StringBuffer -> PsSpan -> P (PsLocated Token) -docCommentEnd input commentAcc docType buf span = do - let finalizeComment str = - let (hdk_comment, token) = docType str - in (Just hdk_comment, token) - commentEnd lexToken input commentAcc finalizeComment buf span +docCommentEnd input (hdk_comment, tok) buf span + = commentEnd lexToken input (Just hdk_comment, tok) buf span errBrace :: AlexInput -> RealSrcSpan -> P a errBrace (AI end _) span = @@ -2331,8 +2351,10 @@ data ParserOpts = ParserOpts pWarningFlags :: ParserOpts -> EnumSet WarningFlag pWarningFlags opts = diag_warning_flags (pDiagOpts opts) --- | Haddock comment as produced by the lexer. These are accumulated in --- 'PState' and then processed in "GHC.Parser.PostProcess.Haddock". +-- | Haddock comment as produced by the lexer. These are accumulated in 'PState' +-- and then processed in "GHC.Parser.PostProcess.Haddock". The location of the +-- 'HsDocString's spans over the contents of the docstring - i.e. it does not +-- include the decorator ("-- |", "{-|" etc.) data HdkComment = HdkCommentNext HsDocString | HdkCommentPrev HsDocString @@ -2596,6 +2618,7 @@ alexGetByte (AI loc s) loc' = advancePsLoc loc c byte = adjustChar c +{-# INLINE alexGetChar' #-} -- This version does not squash unicode characters, it is used when -- lexing strings. alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) @@ -3386,8 +3409,7 @@ reportLexError loc1 loc2 buf f lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token] lexTokenStream opts buf loc = unP go initState{ options = opts' } where - new_exts = xunset HaddockBit -- disable Haddock - $ xunset UsePosPragsBit -- parse LINE/COLUMN pragmas as tokens + new_exts = xunset UsePosPragsBit -- parse LINE/COLUMN pragmas as tokens $ xset RawTokenStreamBit -- include comments $ pExtsBitmap opts opts' = opts { pExtsBitmap = new_exts } @@ -3407,7 +3429,7 @@ fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), ("include", lex_string_prag ITinclude_prag)]) ignoredPrags = Map.fromList (map ignored pragmas) - where ignored opt = (opt, nested_comment lexToken) + where ignored opt = (opt, nested_comment) impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"] options_pragmas = map ("options_" ++) impls -- CFILES is a hugs-only thing. @@ -3553,13 +3575,10 @@ allocateFinalComments ss comment_q mheader_comments = Strict.Just _ -> (mheader_comments, [], comment_q' ++ newAnns) commentToAnnotation :: RealLocated Token -> LEpaComment -commentToAnnotation (L l (ITdocCommentNext s ll)) = mkLEpaComment l ll (EpaDocCommentNext s) -commentToAnnotation (L l (ITdocCommentPrev s ll)) = mkLEpaComment l ll (EpaDocCommentPrev s) -commentToAnnotation (L l (ITdocCommentNamed s ll)) = mkLEpaComment l ll (EpaDocCommentNamed s) -commentToAnnotation (L l (ITdocSection n s ll)) = mkLEpaComment l ll (EpaDocSection n s) -commentToAnnotation (L l (ITdocOptions s ll)) = mkLEpaComment l ll (EpaDocOptions s) -commentToAnnotation (L l (ITlineComment s ll)) = mkLEpaComment l ll (EpaLineComment s) -commentToAnnotation (L l (ITblockComment s ll)) = mkLEpaComment l ll (EpaBlockComment s) +commentToAnnotation (L l (ITdocComment s ll)) = mkLEpaComment l ll (EpaDocComment s) +commentToAnnotation (L l (ITdocOptions s ll)) = mkLEpaComment l ll (EpaDocOptions s) +commentToAnnotation (L l (ITlineComment s ll)) = mkLEpaComment l ll (EpaLineComment s) +commentToAnnotation (L l (ITblockComment s ll)) = mkLEpaComment l ll (EpaBlockComment s) commentToAnnotation _ = panic "commentToAnnotation" -- see Note [PsSpan in Comments] @@ -3569,12 +3588,9 @@ mkLEpaComment l ll tok = L (realSpanAsAnchor l) (EpaComment tok (psRealSpan ll)) -- --------------------------------------------------------------------- isComment :: Token -> Bool -isComment (ITlineComment _ _) = True -isComment (ITblockComment _ _) = True -isComment (ITdocCommentNext _ _) = True -isComment (ITdocCommentPrev _ _) = True -isComment (ITdocCommentNamed _ _) = True -isComment (ITdocSection _ _ _) = True -isComment (ITdocOptions _ _) = True -isComment _ = False +isComment (ITlineComment _ _) = True +isComment (ITblockComment _ _) = True +isComment (ITdocComment _ _) = True +isComment (ITdocOptions _ _) = True +isComment _ = False } diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 08bebc4683..271d9db30f 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -67,7 +67,9 @@ import Control.Monad.Trans.Writer import Data.Functor.Identity import qualified Data.Monoid +import {-# SOURCE #-} GHC.Parser (parseIdentifier) import GHC.Parser.Lexer +import GHC.Parser.HaddockLex import GHC.Parser.Errors.Types import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>)) import qualified GHC.Data.Strict as Strict @@ -252,7 +254,8 @@ instance HasHaddock (Located HsModule) where docs <- inLocRange (locRangeTo (getBufPos (srcSpanStart (locA l_name)))) $ takeHdkComments mkDocNext - selectDocString docs + dc <- selectDocString docs + pure $ lexLHsDocString <$> dc -- Step 2, process documentation comments in the export list: -- @@ -292,6 +295,12 @@ instance HasHaddock (Located HsModule) where , hsmodDecls = hsmodDecls' , hsmodHaddockModHeader = join @Maybe headerDocs } +lexHsDocString :: HsDocString -> HsDoc GhcPs +lexHsDocString = lexHsDoc parseIdentifier + +lexLHsDocString :: Located HsDocString -> LHsDoc GhcPs +lexLHsDocString = fmap lexHsDocString + -- Only for module exports, not module imports. -- -- module M (a, b, c) where -- use on this [LIE GhcPs] @@ -700,7 +709,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where con_res_ty' <- addHaddock con_res_ty pure $ L l_con_decl $ ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, - con_doc = con_doc', + con_doc = lexLHsDocString <$> con_doc', con_g_args = con_g_args', con_res_ty = con_res_ty' } ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } -> @@ -711,7 +720,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where ts' <- traverse addHaddockConDeclFieldTy ts pure $ L l_con_decl $ ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, - con_doc = con_doc', + con_doc = lexLHsDocString <$> con_doc', con_args = PrefixCon noTypeArgs ts' } InfixCon t1 t2 -> do t1' <- addHaddockConDeclFieldTy t1 @@ -719,14 +728,14 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where t2' <- addHaddockConDeclFieldTy t2 pure $ L l_con_decl $ ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, - con_doc = con_doc', + con_doc = lexLHsDocString <$> con_doc', con_args = InfixCon t1' t2' } RecCon (L l_rec flds) -> do con_doc' <- getConDoc (getLocA con_name) flds' <- traverse addHaddockConDeclField flds pure $ L l_con_decl $ ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, - con_doc = con_doc', + con_doc = lexLHsDocString <$> con_doc', con_args = RecCon (L l_rec flds') } -- Keep track of documentation comments on the data constructor or any of its @@ -768,7 +777,7 @@ discardHasInnerDocs = fmap fst . runWriterT -- data/newtype declaration. getConDoc :: SrcSpan -- Location of the data constructor - -> ConHdkA (Maybe LHsDocString) + -> ConHdkA (Maybe (Located HsDocString)) getConDoc l = WriterT $ extendHdkA l $ liftHdkA $ do mDoc <- getPrevNextDoc l @@ -792,7 +801,7 @@ addHaddockConDeclField -> ConHdkA (LConDeclField GhcPs) addHaddockConDeclField (L l_fld fld) = WriterT $ extendHdkA (locA l_fld) $ liftHdkA $ do - cd_fld_doc <- getPrevNextDoc (locA l_fld) + cd_fld_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld) return (L l_fld (fld { cd_fld_doc }), HasInnerDocs (isJust cd_fld_doc)) @@ -861,7 +870,7 @@ addConTrailingDoc l_sep = x <$ reportExtraDocs trailingDocs mk_doc_fld (L l' con_fld) = do doc <- selectDocString trailingDocs - return $ L l' (con_fld { cd_fld_doc = doc }) + return $ L l' (con_fld { cd_fld_doc = fmap lexLHsDocString doc }) con_args' <- case con_args con_decl of x@(PrefixCon _ []) -> x <$ reportExtraDocs trailingDocs x@(RecCon (L _ [])) -> x <$ reportExtraDocs trailingDocs @@ -872,7 +881,7 @@ addConTrailingDoc l_sep = return (RecCon (L l_rec flds')) return $ L l (con_decl{ con_args = con_args' }) else do - con_doc' <- selectDocString (con_doc con_decl `mcons` trailingDocs) + con_doc' <- selectDoc (con_doc con_decl `mcons` (map lexLHsDocString trailingDocs)) return $ L l (con_decl{ con_doc = con_doc' }) _ -> panic "addConTrailingDoc: non-H98 ConDecl" @@ -1196,7 +1205,7 @@ data HdkSt = -- | Warnings accumulated in HdkM. data HdkWarn = HdkWarnInvalidComment (PsLocated HdkComment) - | HdkWarnExtraComment LHsDocString + | HdkWarnExtraComment (Located HsDocString) -- Restrict the range in which a HdkM computation will look up comments: -- @@ -1238,8 +1247,7 @@ takeHdkComments f = (items, other_comments) = foldr add_comment ([], []) comments_in_range remaining_comments = comments_before_range ++ other_comments ++ comments_after_range hdk_st' = hdk_st{ hdk_st_pending = remaining_comments } - in - (items, hdk_st') + in (items, hdk_st') where is_after StartOfFile _ = True is_after (StartLoc l) (L l_comment _) = bufSpanStart (psBufSpan l_comment) >= l @@ -1257,7 +1265,7 @@ takeHdkComments f = Nothing -> (items, hdk_comment : other_hdk_comments) -- Get the docnext or docprev comment for an AST node at the given source span. -getPrevNextDoc :: SrcSpan -> HdkM (Maybe LHsDocString) +getPrevNextDoc :: SrcSpan -> HdkM (Maybe (Located HsDocString)) getPrevNextDoc l = do let (l_start, l_end) = (srcSpanStart l, srcSpanEnd l) before_t = locRangeTo (getBufPos l_start) @@ -1271,7 +1279,7 @@ appendHdkWarning e = HdkM $ \_ hdk_st -> let hdk_st' = hdk_st { hdk_st_warnings = e : hdk_st_warnings hdk_st } in ((), hdk_st') -selectDocString :: [LHsDocString] -> HdkM (Maybe LHsDocString) +selectDocString :: [Located HsDocString] -> HdkM (Maybe (Located HsDocString)) selectDocString = select . filterOut (isEmptyDocString . unLoc) where select [] = return Nothing @@ -1280,7 +1288,16 @@ selectDocString = select . filterOut (isEmptyDocString . unLoc) reportExtraDocs extra_docs return (Just doc) -reportExtraDocs :: [LHsDocString] -> HdkM () +selectDoc :: forall a. [LHsDoc a] -> HdkM (Maybe (LHsDoc a)) +selectDoc = select . filterOut (isEmptyDocString . hsDocString . unLoc) + where + select [] = return Nothing + select [doc] = return (Just doc) + select (doc : extra_docs) = do + reportExtraDocs $ map (\(L l d) -> L l $ hsDocString d) extra_docs + return (Just doc) + +reportExtraDocs :: [Located HsDocString] -> HdkM () reportExtraDocs = traverse_ (\extra_doc -> appendHdkWarning (HdkWarnExtraComment extra_doc)) @@ -1297,13 +1314,14 @@ mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) mkDocDecl layout_info (L l_comment hdk_comment) | indent_mismatch = Nothing | otherwise = - Just $ L (noAnnSrcSpan $ mkSrcSpanPs l_comment) $ + Just $ L (noAnnSrcSpan span) $ case hdk_comment of - HdkCommentNext doc -> DocCommentNext doc - HdkCommentPrev doc -> DocCommentPrev doc - HdkCommentNamed s doc -> DocCommentNamed s doc - HdkCommentSection n doc -> DocGroup n doc + HdkCommentNext doc -> DocCommentNext (L span $ lexHsDocString doc) + HdkCommentPrev doc -> DocCommentPrev (L span $ lexHsDocString doc) + HdkCommentNamed s doc -> DocCommentNamed s (L span $ lexHsDocString doc) + HdkCommentSection n doc -> DocGroup n (L span $ lexHsDocString doc) where + span = mkSrcSpanPs l_comment -- 'indent_mismatch' checks if the documentation comment has the exact -- indentation level expected by the parent node. -- @@ -1332,18 +1350,19 @@ mkDocDecl layout_info (L l_comment hdk_comment) mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) mkDocIE (L l_comment hdk_comment) = case hdk_comment of - HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n doc) + HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n $ L span $ lexHsDocString doc) HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s) - HdkCommentNext doc -> Just $ L l (IEDoc noExtField doc) + HdkCommentNext doc -> Just $ L l (IEDoc noExtField $ L span $ lexHsDocString doc) _ -> Nothing - where l = noAnnSrcSpan $ mkSrcSpanPs l_comment + where l = noAnnSrcSpan span + span = mkSrcSpanPs l_comment -mkDocNext :: PsLocated HdkComment -> Maybe LHsDocString -mkDocNext (L l (HdkCommentNext doc)) = Just $ L (mkSrcSpanPs l) doc +mkDocNext :: PsLocated HdkComment -> Maybe (Located HsDocString) +mkDocNext (L l (HdkCommentNext doc)) = Just (L (mkSrcSpanPs l) doc) mkDocNext _ = Nothing -mkDocPrev :: PsLocated HdkComment -> Maybe LHsDocString -mkDocPrev (L l (HdkCommentPrev doc)) = Just $ L (mkSrcSpanPs l) doc +mkDocPrev :: PsLocated HdkComment -> Maybe (Located HsDocString) +mkDocPrev (L l (HdkCommentPrev doc)) = Just (L (mkSrcSpanPs l) doc) mkDocPrev _ = Nothing @@ -1396,6 +1415,7 @@ locRangeTo Strict.Nothing = mempty -- We'd rather only do the (>=40) check. So we reify the predicate to make -- sure we only check for the most restrictive bound. data LowerLocBound = StartOfFile | StartLoc !BufPos + deriving Show instance Semigroup LowerLocBound where StartOfFile <> l = l @@ -1424,6 +1444,7 @@ instance Monoid LowerLocBound where -- We'd rather only do the (<=20) check. So we reify the predicate to make -- sure we only check for the most restrictive bound. data UpperLocBound = EndOfFile | EndLoc !BufPos + deriving Show instance Semigroup UpperLocBound where EndOfFile <> l = l @@ -1442,6 +1463,7 @@ instance Monoid UpperLocBound where -- The semigroup instance corresponds to (&&). -- newtype ColumnBound = ColumnFrom Int -- n >= GHC.Types.SrcLoc.leftmostColumn + deriving Show instance Semigroup ColumnBound where ColumnFrom n <> ColumnFrom m = ColumnFrom (max n m) @@ -1456,9 +1478,9 @@ instance Monoid ColumnBound where * * ********************************************************************* -} -mkLHsDocTy :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs +mkLHsDocTy :: LHsType GhcPs -> Maybe (Located HsDocString) -> LHsType GhcPs mkLHsDocTy t Nothing = t -mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t doc) +mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t $ lexLHsDocString doc) getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan getForAllTeleLoc tele = diff --git a/compiler/GHC/Rename/Doc.hs b/compiler/GHC/Rename/Doc.hs new file mode 100644 index 0000000000..b278e02cf3 --- /dev/null +++ b/compiler/GHC/Rename/Doc.hs @@ -0,0 +1,46 @@ +module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnLDocDecl, rnDocDecl ) where + +import GHC.Prelude + +import GHC.Tc.Types +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Tc.Utils.Monad (getGblEnv) +import GHC.Types.Avail +import GHC.Rename.Env + +rnLHsDoc :: LHsDoc GhcPs -> RnM (LHsDoc GhcRn) +rnLHsDoc = traverse rnHsDoc + +rnLDocDecl :: LDocDecl GhcPs -> RnM (LDocDecl GhcRn) +rnLDocDecl = traverse rnDocDecl + +rnDocDecl :: DocDecl GhcPs -> RnM (DocDecl GhcRn) +rnDocDecl (DocCommentNext doc) = do + doc' <- rnLHsDoc doc + pure $ (DocCommentNext doc') +rnDocDecl (DocCommentPrev doc) = do + doc' <- rnLHsDoc doc + pure $ (DocCommentPrev doc') +rnDocDecl (DocCommentNamed n doc) = do + doc' <- rnLHsDoc doc + pure $ (DocCommentNamed n doc') +rnDocDecl (DocGroup i doc) = do + doc' <- rnLHsDoc doc + pure $ (DocGroup i doc') + +rnHsDoc :: WithHsDocIdentifiers a GhcPs -> RnM (WithHsDocIdentifiers a GhcRn) +rnHsDoc (WithHsDocIdentifiers s ids) = do + gre <- tcg_rdr_env <$> getGblEnv + pure (WithHsDocIdentifiers s (rnHsDocIdentifiers gre ids)) + +rnHsDocIdentifiers :: GlobalRdrEnv + -> [Located RdrName] + -> [Located Name] +rnHsDocIdentifiers gre ns = concat + [ map (L l . greNamePrintableName . gre_name) (lookupGRE_RdrName c gre) + | L l rdr_name <- ns + , c <- dataTcOccs rdr_name + ] diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 3525c71f1b..2440976b31 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -1583,7 +1583,7 @@ warnIfDeprecated gre@(GRE { gre_imp = iss }) extra | imp_mod == moduleName name_mod = Outputable.empty | otherwise = text ", but defined in" <+> ppr name_mod -lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt +lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) lookupImpDeprec iface gre = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing, case gre_par gre of -- or its parent, is warn'd diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index edda60fbee..ae22cfa0cb 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -48,6 +48,7 @@ import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) import GHC.Driver.Session import GHC.Hs import GHC.Rename.Env +import GHC.Rename.Doc import GHC.Rename.Utils ( mapFvRn, bindLocalNamesFV , typeAppErr, newLocalBndrRn, checkDupRdrNamesN , checkShadowedRdrNames, warnForallIdentifier ) @@ -733,7 +734,8 @@ rnHsTyKi _ (HsSpliceTy _ sp) rnHsTyKi env (HsDocTy x ty haddock_doc) = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsDocTy x ty' haddock_doc, fvs) } + ; haddock_doc' <- rnLHsDoc haddock_doc + ; return (HsDocTy x ty' haddock_doc', fvs) } -- See Note [Renaming HsCoreTys] rnHsTyKi env (XHsType ty) @@ -1271,7 +1273,8 @@ rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) = do { mapM_ (\(L _ (FieldOcc _ rdr_name)) -> warnForallIdentifier rdr_name) names ; let new_names = map (fmap (lookupField fl_env)) names ; (new_ty, fvs) <- rnLHsTyKi env ty - ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc) + ; haddock_doc' <- traverse rnLHsDoc haddock_doc + ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc') , fvs) } lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index b46528c6ed..9fbbcacdab 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -13,7 +13,7 @@ Main pass of renamer -} module GHC.Rename.Module ( - rnSrcDecls, addTcgDUs, findSplice + rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt ) where import GHC.Prelude @@ -27,6 +27,7 @@ import GHC.Types.FieldLabel import GHC.Types.Name.Reader import GHC.Rename.HsType import GHC.Rename.Bind +import GHC.Rename.Doc import GHC.Rename.Env import GHC.Rename.Utils ( mapFvRn, bindLocalNames , checkDupRdrNamesN, bindLocalNamesFV @@ -205,6 +206,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ; + rn_docs <- traverse rnLDocDecl docs ; last_tcg_env <- getGblEnv ; -- (I) Compute the results and return @@ -220,7 +222,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, hs_annds = rn_ann_decls, hs_defds = rn_default_decls, hs_ruleds = rn_rule_decls, - hs_docs = docs } ; + hs_docs = rn_docs } ; tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ; other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ; @@ -264,7 +266,7 @@ gather them together. -} -- checks that the deprecations are defined locally, and that there are no duplicates -rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings +rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn) rnSrcWarnDecls _ [] = return NoWarnings @@ -284,13 +286,23 @@ rnSrcWarnDecls bndr_set decls' -- ensures that the names are defined locally = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) rdr_names - ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] } + ; txt' <- rnWarningTxt txt + ; return [(rdrNameOcc rdr, txt') | (rdr, _) <- names] } what = text "deprecation" warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls +rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn) +rnWarningTxt (WarningTxt st wst) = do + wst' <- traverse (traverse rnHsDoc) wst + pure (WarningTxt st wst') +rnWarningTxt (DeprecatedTxt st wst) = do + wst' <- traverse (traverse rnHsDoc) wst + pure (DeprecatedTxt st wst') + + findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) @@ -1878,11 +1890,12 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, -- and the methods are already in scope ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs + ; docs' <- traverse rnLDocDecl docs ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', tcdTyVars = tyvars', tcdFixity = fixity, tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', - tcdDocs = docs, tcdCExt = all_fvs }, + tcdDocs = docs', tcdCExt = all_fvs }, all_fvs ) } where cls_doc = ClassDeclCtx lcls @@ -2328,10 +2341,11 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs [ text "ex_tvs:" <+> ppr ex_tvs , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) + ; mb_doc' <- traverse rnLHsDoc mb_doc ; return (decl { con_ext = noAnn , con_name = new_name, con_ex_tvs = new_ex_tvs , con_mb_cxt = new_context, con_args = new_args - , con_doc = mb_doc + , con_doc = mb_doc' , con_forall = forall_ }, -- Remove when #18311 is fixed all_fvs) }} @@ -2372,10 +2386,11 @@ rnConDecl (ConDeclGADT { con_names = names ; traceRn "rnConDecl (ConDeclGADT)" (ppr names $$ ppr outer_bndrs') + ; new_mb_doc <- traverse rnLHsDoc mb_doc ; return (ConDeclGADT { con_g_ext = noAnn, con_names = new_names , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt , con_g_args = new_args, con_res_ty = new_res_ty - , con_doc = mb_doc }, + , con_doc = new_mb_doc }, all_fvs) } } rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index d2573b2b25..3a4cb78820 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -2163,14 +2163,14 @@ missingImportListWarn :: ModuleName -> SDoc missingImportListWarn mod = text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list" -moduleWarn :: ModuleName -> WarningTxt -> SDoc +moduleWarn :: ModuleName -> WarningTxt GhcRn -> SDoc moduleWarn mod (WarningTxt _ txt) = sep [ text "Module" <+> quotes (ppr mod) <> colon, - nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] + nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ] moduleWarn mod (DeprecatedTxt _ txt) = sep [ text "Module" <+> quotes (ppr mod) <+> text "is deprecated:", - nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] + nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ] packageImportErr :: TcRnMessage packageImportErr diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 9f2c257435..bf6227737f 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -108,6 +108,7 @@ import GHC.Types.Unique.Supply import GHC.Types.Unique.DSet import GHC.Types.TyThing import GHC.Types.BreakInfo +import GHC.Types.Unique.Map import GHC.Unit import GHC.Unit.Module.Graph @@ -121,7 +122,6 @@ import Data.Either import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (find,intercalate) -import qualified Data.Map as Map import Control.Monad import Control.Monad.Catch as MC import Data.Array @@ -909,7 +909,7 @@ parseName str = withSession $ \hsc_env -> liftIO $ getDocs :: GhcMonad m => Name - -> m (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)) + -> m (Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))) -- TODO: What about docs for constructors etc.? getDocs name = withSession $ \hsc_env -> do @@ -919,14 +919,14 @@ getDocs name = if isInteractiveModule mod then pure (Left InteractiveName) else do - ModIface { mi_doc_hdr = mb_doc_hdr - , mi_decl_docs = DeclDocMap dmap - , mi_arg_docs = ArgDocMap amap - } <- liftIO $ hscGetModuleInterface hsc_env mod - if isNothing mb_doc_hdr && Map.null dmap && Map.null amap - then pure (Left (NoDocsInIface mod compiled)) - else pure (Right ( Map.lookup name dmap - , Map.findWithDefault mempty name amap)) + iface <- liftIO $ hscGetModuleInterface hsc_env mod + case mi_docs iface of + Nothing -> pure (Left (NoDocsInIface mod compiled)) + Just Docs { docs_decls = decls + , docs_args = args + } -> + pure (Right ( lookupUniqMap decls name + , fromMaybe mempty $ lookupUniqMap args name)) where compiled = -- TODO: Find a more direct indicator. @@ -935,16 +935,12 @@ getDocs name = UnhelpfulLoc {} -> True -- | Failure modes for 'getDocs'. - --- TODO: Find a way to differentiate between modules loaded without '-haddock' --- and modules that contain no docs. data GetDocsFailure -- | 'nameModule_maybe' returned 'Nothing'. = NameHasNoModule Name - -- | This is probably because the module was loaded without @-haddock@, - -- but it's also possible that the entire module contains no documentation. + -- | The module was loaded without @-haddock@, | NoDocsInIface Module Bool -- ^ 'True': The module was compiled. @@ -958,11 +954,6 @@ instance Outputable GetDocsFailure where quotes (ppr name) <+> text "has no module where we could look for docs." ppr (NoDocsInIface mod compiled) = vcat [ text "Can't find any documentation for" <+> ppr mod <> char '.' - , text "This is probably because the module was" - <+> text (if compiled then "compiled" else "loaded") - <+> text "without '-haddock'," - , text "but it's also possible that the module contains no documentation." - , text "" , if compiled then text "Try re-compiling with '-haddock'." else text "Try running ':set -haddock' and :load the file again." diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index 079bbd5df5..fcae57f975 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -73,14 +73,18 @@ import GHC.Tc.Solver.Monad ( runTcSEarlyAbort ) import GHC.Tc.Utils.Unify ( tcSubTypeSigma ) import GHC.HsToCore.Docs ( extractDocs ) -import qualified Data.Map as Map -import GHC.Hs.Doc ( unpackHDS, DeclDocMap(..) ) +import GHC.Hs.Doc import GHC.Unit.Module.ModIface ( ModIface_(..) ) -import GHC.Iface.Load ( loadInterfaceForNameMaybe ) +import GHC.Iface.Load ( loadInterfaceForName ) import GHC.Builtin.Utils (knownKeyNames) import GHC.Tc.Errors.Hole.FitTypes +import qualified Data.Set as Set +import GHC.Types.SrcLoc +import GHC.Utils.Trace (warnPprTrace) +import GHC.Data.FastString (unpackFS) +import GHC.Types.Unique.Map {- @@ -456,21 +460,40 @@ addHoleFitDocs :: [HoleFit] -> TcM [HoleFit] addHoleFitDocs fits = do { showDocs <- goptM Opt_ShowDocsOfHoleFits ; if showDocs - then do { (_, DeclDocMap lclDocs, _) <- getGblEnv >>= extractDocs - ; mapM (upd lclDocs) fits } + then do { dflags <- getDynFlags + ; mb_local_docs <- extractDocs dflags =<< getGblEnv + ; (mods_without_docs, fits') <- mapAccumM (upd mb_local_docs) Set.empty fits + ; report mods_without_docs + ; return fits' } else return fits } where msg = text "GHC.Tc.Errors.Hole addHoleFitDocs" - lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap }) - = Map.lookup name dmap - upd lclDocs fit@(HoleFit {hfCand = cand}) = - do { let name = getName cand - ; doc <- if hfIsLcl fit - then pure (Map.lookup name lclDocs) - else do { mbIface <- loadInterfaceForNameMaybe msg name - ; return $ mbIface >>= lookupInIface name } - ; return $ fit {hfDoc = doc} } - upd _ fit = return fit + upd mb_local_docs mods_without_docs fit@(HoleFit {hfCand = cand}) = + let name = getName cand in + do { mb_docs <- if hfIsLcl fit + then pure mb_local_docs + else mi_docs <$> loadInterfaceForName msg name + ; case mb_docs of + { Nothing -> return (Set.insert (nameOrigin name) mods_without_docs, fit) + ; Just docs -> do + { let doc = lookupUniqMap (docs_decls docs) name + ; return $ (mods_without_docs, fit {hfDoc = map hsDocString <$> doc}) }}} + upd _ mods_without_docs fit = pure (mods_without_docs, fit) + nameOrigin name = case nameModule_maybe name of + Just m -> Right m + Nothing -> + Left $ case nameSrcLoc name of + RealSrcLoc r _ -> unpackFS $ srcLocFile r + UnhelpfulLoc s -> unpackFS $ s + report mods = do + { let warning = + text "WARNING: Couldn't find any documentation for the following modules:" $+$ + nest 2 + (fsep (punctuate comma + (either text ppr <$> Set.toList mods)) $+$ + text "Make sure the modules are compiled with '-haddock'.") + ; warnPprTrace (not $ Set.null mods)"addHoleFitDocs" warning (pure ()) + } -- For pretty printing hole fits, we display the name and type of the fit, -- with added '_' to represent any extra arguments in case of a non-zero @@ -517,9 +540,7 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = then occDisp <+> tyApp else tyAppVars docs = case hfDoc of - Just d -> text "{-^" <> - (vcat . map text . lines . unpackHDS) d - <> text "-}" + Just d -> pprHsDocStrings d _ -> empty funcInfo = ppWhen (has hfMatches && sTy) $ text "where" <+> occDisp <+> tyDisp diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs index 077bdaab18..72cb54bec2 100644 --- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs @@ -87,7 +87,7 @@ data HoleFit = , hfWrap :: [TcType] -- ^ The wrapper for the match. , hfMatches :: [TcType] -- ^ What the refinement variables got matched with, if anything - , hfDoc :: Maybe HsDocString + , hfDoc :: Maybe [HsDocString] -- ^ Documentation of this HoleFit, if available. } | RawHoleFit SDoc diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot index c6141d8897..8943c3f0a2 100644 --- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot @@ -25,6 +25,6 @@ data HoleFit = , hfRefLvl :: Int , hfWrap :: [TcType] , hfMatches :: [TcType] - , hfDoc :: Maybe HsDocString + , hfDoc :: Maybe [HsDocString] } | RawHoleFit SDoc diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index 2055b3101c..26b765a9d1 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -44,6 +44,7 @@ import Control.Monad import GHC.Driver.Session import GHC.Parser.PostProcess ( setRdrNameSpace ) import Data.Either ( partitionEithers ) +import GHC.Rename.Doc {- ************************************************************************ @@ -316,12 +317,12 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod , ( L loc (IEModuleContents noExtField lmod) , new_exports))) } - exports_from_item acc@(ExportAccum occs mods) (L loc ie) - | Just new_ie <- lookup_doc_ie ie - = return (Just (acc, (L loc new_ie, []))) - - | otherwise - = do (new_ie, avail) <- lookup_ie ie + exports_from_item acc@(ExportAccum occs mods) (L loc ie) = do + m_new_ie <- lookup_doc_ie ie + case m_new_ie of + Just new_ie -> return (Just (acc, (L loc new_ie, []))) + Nothing -> do + (new_ie, avail) <- lookup_ie ie if isUnboundName (ieName new_ie) then return Nothing -- Avoid error cascade else do @@ -396,11 +397,15 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod return (L (locA l) name, non_flds, flds) ------------- - lookup_doc_ie :: IE GhcPs -> Maybe (IE GhcRn) - lookup_doc_ie (IEGroup _ lev doc) = Just (IEGroup noExtField lev doc) - lookup_doc_ie (IEDoc _ doc) = Just (IEDoc noExtField doc) - lookup_doc_ie (IEDocNamed _ str) = Just (IEDocNamed noExtField str) - lookup_doc_ie _ = Nothing + lookup_doc_ie :: IE GhcPs -> RnM (Maybe (IE GhcRn)) + lookup_doc_ie (IEGroup _ lev doc) = do + doc' <- rnLHsDoc doc + pure $ Just (IEGroup noExtField lev doc') + lookup_doc_ie (IEDoc _ doc) = do + doc' <- rnLHsDoc doc + pure $ Just (IEDoc noExtField doc') + lookup_doc_ie (IEDocNamed _ str) = pure $ Just (IEDocNamed noExtField str) + lookup_doc_ie _ = pure Nothing -- In an export item M.T(A,B,C), we want to treat the uses of -- A,B,C as if they were M.A, M.B, M.C diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index c42dd689fa..6860eba567 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -10,6 +10,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE NamedFieldPuns #-} {- (c) The University of Glasgow 2006 @@ -110,6 +111,7 @@ import GHC.Types.Error import GHC.Types.Fixity as Hs import GHC.Types.Annotations import GHC.Types.Name +import GHC.Types.Unique.Map import GHC.Serialized import GHC.Unit.Finder @@ -154,6 +156,9 @@ import qualified Data.Map as Map import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) import Data.Proxy ( Proxy (..) ) +import GHC.Parser.HaddockLex (lexHsDoc) +import GHC.Parser (parseIdentifier) +import GHC.Rename.Doc (rnHsDoc) {- ************************************************************************ @@ -1307,7 +1312,10 @@ instance TH.Quasi TcM where unless is_local $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Can't add documentation to" <+> ppr_loc doc_loc <+> text "as it isn't inside the current module" - updTcRef th_doc_var (Map.insert resolved_doc_loc s) + let ds = mkGeneratedHsDocString s + hd = lexHsDoc parseIdentifier ds + hd' <- rnHsDoc hd + updTcRef th_doc_var (Map.insert resolved_doc_loc hd') where resolve_loc (TH.DeclDoc n) = DeclDoc <$> lookupThName n resolve_loc (TH.ArgDoc n i) = ArgDoc <$> lookupThName n <*> pure i @@ -1331,40 +1339,41 @@ instance TH.Quasi TcM where qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i qGetDoc TH.ModuleDoc = do - (moduleDoc, _, _) <- getGblEnv >>= extractDocs - return (fmap unpackHDS moduleDoc) + df <- getDynFlags + docs <- getGblEnv >>= extractDocs df + return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs)) -- | Looks up documentation for a declaration in first the current module, -- otherwise tries to find it in another module via 'hscGetModuleInterface'. lookupDeclDoc :: Name -> TcM (Maybe String) lookupDeclDoc nm = do - (_, DeclDocMap declDocs, _) <- getGblEnv >>= extractDocs - fam_insts <- tcg_fam_insts <$> getGblEnv - traceTc "lookupDeclDoc" (ppr nm <+> ppr declDocs <+> ppr fam_insts) - case Map.lookup nm declDocs of - Just doc -> pure $ Just (unpackHDS doc) + df <- getDynFlags + Docs{docs_decls} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df + case lookupUniqMap docs_decls nm of + Just doc -> pure $ Just (renderHsDocStrings $ map hsDocString doc) Nothing -> do -- Wasn't in the current module. Try searching other external ones! mIface <- getExternalModIface nm case mIface of - Nothing -> pure Nothing - Just ModIface { mi_decl_docs = DeclDocMap dmap } -> - pure $ unpackHDS <$> Map.lookup nm dmap + Just ModIface { mi_docs = Just Docs{docs_decls = dmap} } -> + pure $ renderHsDocStrings . map hsDocString <$> lookupUniqMap dmap nm + _ -> pure Nothing -- | Like 'lookupDeclDoc', looks up documentation for a function argument. If -- it can't find any documentation for a function in this module, it tries to -- find it in another module. lookupArgDoc :: Int -> Name -> TcM (Maybe String) lookupArgDoc i nm = do - (_, _, ArgDocMap argDocs) <- getGblEnv >>= extractDocs - case Map.lookup nm argDocs of - Just m -> pure $ unpackHDS <$> IntMap.lookup i m + df <- getDynFlags + Docs{docs_args = argDocs} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df + case lookupUniqMap argDocs nm of + Just m -> pure $ renderHsDocString . hsDocString <$> IntMap.lookup i m Nothing -> do mIface <- getExternalModIface nm case mIface of - Nothing -> pure Nothing - Just ModIface { mi_arg_docs = ArgDocMap amap } -> - pure $ unpackHDS <$> (Map.lookup nm amap >>= IntMap.lookup i) + Just ModIface { mi_docs = Just Docs{docs_args = amap} } -> + pure $ renderHsDocString . hsDocString <$> (lookupUniqMap amap nm >>= IntMap.lookup i) + _ -> pure Nothing -- | Returns the module a Name belongs to, if it is isn't local. getExternalModIface :: Name -> TcM (Maybe ModIface) diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index dca5bce99e..e690d1e5a2 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -95,6 +95,7 @@ import GHC.Rename.Fixity ( lookupFixityRn ) import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Module +import GHC.Rename.Doc import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) import GHC.Iface.Type ( ShowForAllFlag(..) ) @@ -292,22 +293,23 @@ tcRnModuleTcRnM hsc_env mod_sum tcg_env <- {-# SCC "tcRnImports" #-} tcRnImports hsc_env all_imports - ; -- Don't need to rename the Haddock documentation, - -- it's not parsed by GHC anymore. - -- Make sure to do this before 'tcRnSrcDecls', because we need the - -- module header when we're splicing TH, since it can be accessed via - -- 'getDoc'. - tcg_env <- return (tcg_env - { tcg_doc_hdr = maybe_doc_hdr }) - + -- Put a version of the header without identifier info into the tcg_env + -- Make sure to do this before 'tcRnSrcDecls', because we need the + -- module header when we're splicing TH, since it can be accessed via + -- 'getDoc'. + -- We will rename it properly after renaming everything else so that + -- haddock can link the identifiers + ; tcg_env <- return (tcg_env + { tcg_doc_hdr = fmap (\(WithHsDocIdentifiers str _) -> WithHsDocIdentifiers str []) + <$> maybe_doc_hdr }) ; -- If the whole module is warned about or deprecated -- (via mod_deprec) record that in tcg_warns. If we do thereby add -- a WarnAll, it will override any subsequent deprecations added to tcg_warns - let { tcg_env1 = case mod_deprec of - Just (L _ txt) -> - tcg_env {tcg_warns = WarnAll txt} - Nothing -> tcg_env - } + ; tcg_env1 <- case mod_deprec of + Just (L _ txt) -> do { txt' <- rnWarningTxt txt + ; pure $ tcg_env {tcg_warns = WarnAll txt'} + } + Nothing -> pure tcg_env ; setGblEnv tcg_env1 $ do { -- Rename and type check the declarations traceRn "rn1a" empty @@ -337,11 +339,17 @@ tcRnModuleTcRnM hsc_env mod_sum -- because the latter might add new bindings for -- boot_dfuns, which may be mentioned in imported -- unfoldings. - -- Report unused names + ; -- Report unused names -- Do this /after/ typeinference, so that when reporting -- a function with no type signature we can give the -- inferred type - reportUnusedNames tcg_env hsc_src + ; reportUnusedNames tcg_env hsc_src + + -- Rename the module header properly after we have renamed everything else + ; maybe_doc_hdr <- traverse rnLHsDoc maybe_doc_hdr; + ; tcg_env <- return (tcg_env + { tcg_doc_hdr = maybe_doc_hdr }) + ; -- add extra source files to tcg_dependent_files addDependentFiles src_files -- Ensure plugins run with the same tcg_env that we pass in @@ -3174,7 +3182,7 @@ runRenamerPlugin gbl_env hs_group = do -- exception/signal an error. type RenamedStuff = (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe LHsDocString)) + Maybe (LHsDoc GhcRn))) -- | Extract the renamed information from TcGblEnv. getRenamedStuff :: TcGblEnv -> RenamedStuff diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 776d0f40fb..d837b629ec 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -591,7 +591,7 @@ data TcGblEnv tcg_binds :: LHsBinds GhcTc, -- Value bindings in this module tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids - tcg_warns :: Warnings, -- ...Warnings and deprecations + tcg_warns :: (Warnings GhcRn), -- ...Warnings and deprecations tcg_anns :: [Annotation], -- ...Annotations tcg_tcs :: [TyCon], -- ...TyCons and Classes tcg_ksigs :: NameSet, -- ...Top-level TyCon names that *lack* a signature @@ -601,7 +601,7 @@ data TcGblEnv tcg_fords :: [LForeignDecl GhcTc], -- ...Foreign import & exports tcg_patsyns :: [PatSyn], -- ...Pattern synonyms - tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs + tcg_doc_hdr :: Maybe (LHsDoc GhcRn), -- ^ Maybe Haddock header docs tcg_hpc :: !AnyHpcUsage, -- ^ @True@ if any part of the -- prog uses hpc instrumentation. -- NB. BangPattern is to fix a leak, see #15111 @@ -1873,4 +1873,4 @@ data DocLoc = DeclDoc Name -- | The current collection of docs that Template Haskell has built up via -- putDoc. -type THDocs = Map DocLoc String +type THDocs = Map DocLoc (HsDoc GhcRn) diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 7c270e39bd..993f458731 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -24,7 +24,7 @@ module GHC.Tc.Utils.Env( tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedClass, tcLookupAxiom, - lookupGlobal, ioLookupDataCon, + lookupGlobal, lookupGlobal_maybe, ioLookupDataCon, addTypecheckedBinds, -- Local environment diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 9f4cedbb39..2e234c383b 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -16,6 +16,7 @@ types that {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs index 6a2bc2c814..a6f27f38e6 100644 --- a/compiler/GHC/Types/SrcLoc.hs +++ b/compiler/GHC/Types/SrcLoc.hs @@ -82,6 +82,7 @@ module GHC.Types.SrcLoc ( getLoc, unLoc, unRealSrcSpan, getRealSrcSpan, pprLocated, + pprLocatedAlways, -- ** Modifying Located mapLoc, @@ -106,6 +107,7 @@ module GHC.Types.SrcLoc ( psSpanEnd, mkSrcSpanPs, combineRealSrcSpans, + psLocatedToLocated, -- * Layout information LayoutInfo(..), @@ -222,7 +224,7 @@ data RealSrcLoc -- We use 'BufPos' in in GHC.Parser.PostProcess.Haddock to associate Haddock -- comments with parts of the AST using location information (#17544). newtype BufPos = BufPos { bufPos :: Int } - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Data) -- | Source Location data SrcLoc @@ -371,7 +373,7 @@ data RealSrcSpan -- | StringBuffer Source Span data BufSpan = BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos } - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Data) instance Semigroup BufSpan where BufSpan start1 end1 <> BufSpan start2 end2 = @@ -730,7 +732,7 @@ pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) -- | We attach SrcSpans to lots of things, so let's have a datatype for it. data GenLocated l e = L l e - deriving (Eq, Ord, Data, Functor, Foldable, Traversable) + deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable) type Located = GenLocated SrcSpan type RealLocated = GenLocated RealSrcSpan @@ -798,6 +800,12 @@ pprLocated (L l e) = whenPprDebug (braces (ppr l)) $$ ppr e +-- | Always prints the location, even without -dppr-debug +pprLocatedAlways :: (Outputable l, Outputable e) => GenLocated l e -> SDoc +pprLocatedAlways (L l e) = + braces (ppr l) + $$ ppr e + {- ************************************************************************ * * @@ -865,10 +873,13 @@ data PsLoc data PsSpan = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan } - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Data) type PsLocated = GenLocated PsSpan +psLocatedToLocated :: PsLocated a -> Located a +psLocatedToLocated (L sp a) = L (mkSrcSpanPs sp) a + advancePsLoc :: PsLoc -> Char -> PsLoc advancePsLoc (PsLoc real_loc buf_loc) c = PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc) diff --git a/compiler/GHC/Types/Unique/Map.hs b/compiler/GHC/Types/Unique/Map.hs index dfbc13fe4f..18d3b2a73a 100644 --- a/compiler/GHC/Types/Unique/Map.hs +++ b/compiler/GHC/Types/Unique/Map.hs @@ -41,7 +41,8 @@ module GHC.Types.Unique.Map ( lookupWithDefaultUniqMap, anyUniqMap, allUniqMap, - nonDetEltsUniqMap + nonDetEltsUniqMap, + nonDetFoldUniqMap -- Non-deterministic functions omitted ) where @@ -208,3 +209,6 @@ allUniqMap f (UniqMap m) = allUFM (f . snd) m nonDetEltsUniqMap :: UniqMap k a -> [(k, a)] nonDetEltsUniqMap (UniqMap m) = nonDetEltsUFM m + +nonDetFoldUniqMap :: ((k, a) -> b -> b) -> b -> UniqMap k a -> b +nonDetFoldUniqMap go z (UniqMap m) = foldUFM go z m diff --git a/compiler/GHC/Unit/Module/ModGuts.hs b/compiler/GHC/Unit/Module/ModGuts.hs index 4fc683d844..d54e836d71 100644 --- a/compiler/GHC/Unit/Module/ModGuts.hs +++ b/compiler/GHC/Unit/Module/ModGuts.hs @@ -72,7 +72,7 @@ data ModGuts mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module mg_foreign_files :: ![(ForeignSrcLang, FilePath)], -- ^ Files to be compiled with the C compiler - mg_warns :: !Warnings, -- ^ Warnings declared in the module + mg_warns :: !(Warnings GhcRn), -- ^ Warnings declared in the module mg_anns :: [Annotation], -- ^ Annotations declared in this module mg_complete_matches :: [CompleteMatch], -- ^ Complete Matches mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module @@ -97,9 +97,7 @@ data ModGuts -- See Note [Trust Own Package] -- in "GHC.Rename.Names" - mg_doc_hdr :: !(Maybe HsDocString), -- ^ Module header. - mg_decl_docs :: !DeclDocMap, -- ^ Docs on declarations. - mg_arg_docs :: !ArgDocMap -- ^ Docs on arguments. + mg_docs :: !(Maybe Docs) -- ^ Documentation. } mg_mnwib :: ModGuts -> ModuleNameWithIsBoot diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs index db7c4ce362..5a3cfe71c9 100644 --- a/compiler/GHC/Unit/Module/ModIface.hs +++ b/compiler/GHC/Unit/Module/ModIface.hs @@ -109,7 +109,7 @@ data ModIfaceBackend = ModIfaceBackend -- other fields and are not put into the interface file. -- Not really produced by the backend but there is no need to create them -- any earlier. - , mi_warn_fn :: !(OccName -> Maybe WarningTxt) + , mi_warn_fn :: !(OccName -> Maybe (WarningTxt GhcRn)) -- ^ Cached lookup for 'mi_warns' , mi_fix_fn :: !(OccName -> Maybe Fixity) -- ^ Cached lookup for 'mi_fixities' @@ -184,7 +184,7 @@ data ModIface_ (phase :: ModIfacePhase) -- ^ Fixities -- NOT STRICT! we read this field lazily from the interface file - mi_warns :: Warnings, + mi_warns :: (Warnings GhcRn), -- ^ Warnings -- NOT STRICT! we read this field lazily from the interface file @@ -235,14 +235,11 @@ data ModIface_ (phase :: ModIfacePhase) -- See Note [Trust Own Package] in GHC.Rename.Names mi_complete_matches :: ![IfaceCompleteMatch], - mi_doc_hdr :: Maybe HsDocString, - -- ^ Module header. - - mi_decl_docs :: DeclDocMap, - -- ^ Docs on declarations. - - mi_arg_docs :: ArgDocMap, - -- ^ Docs on arguments. + mi_docs :: Maybe Docs, + -- ^ Docstrings and related data for use by haddock, the ghci + -- @:doc@ command, and other tools. + -- + -- @Just _@ @<=>@ the module was built with @-haddock@. mi_final_exts :: !(IfaceBackendExts phase), -- ^ Either `()` or `ModIfaceBackend` for @@ -359,9 +356,7 @@ instance Binary ModIface where mi_trust = trust, mi_trust_pkg = trust_pkg, mi_complete_matches = complete_matches, - mi_doc_hdr = doc_hdr, - mi_decl_docs = decl_docs, - mi_arg_docs = arg_docs, + mi_docs = docs, mi_ext_fields = _ext_fields, -- Don't `put_` this in the instance so we -- can deal with it's pointer in the header -- when we write the actual file @@ -405,9 +400,7 @@ instance Binary ModIface where put_ bh trust put_ bh trust_pkg put_ bh complete_matches - lazyPut bh doc_hdr - lazyPut bh decl_docs - lazyPut bh arg_docs + lazyPutMaybe bh docs get bh = do mod <- get bh @@ -438,9 +431,7 @@ instance Binary ModIface where trust <- get bh trust_pkg <- get bh complete_matches <- get bh - doc_hdr <- lazyGet bh - decl_docs <- lazyGet bh - arg_docs <- lazyGet bh + docs <- lazyGetMaybe bh return (ModIface { mi_module = mod, mi_sig_of = sig_of, @@ -464,9 +455,7 @@ instance Binary ModIface where mi_trust_pkg = trust_pkg, -- And build the cached values mi_complete_matches = complete_matches, - mi_doc_hdr = doc_hdr, - mi_decl_docs = decl_docs, - mi_arg_docs = arg_docs, + mi_docs = docs, mi_ext_fields = emptyExtensibleFields, -- placeholder because this is dealt -- with specially when the file is read mi_final_exts = ModIfaceBackend { @@ -510,9 +499,7 @@ emptyPartialModIface mod mi_trust = noIfaceTrustInfo, mi_trust_pkg = False, mi_complete_matches = [], - mi_doc_hdr = Nothing, - mi_decl_docs = emptyDeclDocMap, - mi_arg_docs = emptyArgDocMap, + mi_docs = Nothing, mi_final_exts = (), mi_ext_fields = emptyExtensibleFields } @@ -554,11 +541,11 @@ emptyIfaceHashCache _occ = Nothing -- avoid major space leaks. instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 - f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25) = + f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23) = rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq` f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23 - `seq` rnf f24 `seq` f25 `seq` () + `seq` () instance NFData (ModIfaceBackend) where rnf (ModIfaceBackend f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13) diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs index d8847be72c..6936702b2a 100644 --- a/compiler/GHC/Unit/Module/Warnings.hs +++ b/compiler/GHC/Unit/Module/Warnings.hs @@ -1,4 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} -- | Warnings for a module module GHC.Unit.Module.Warnings @@ -16,25 +20,31 @@ import GHC.Prelude import GHC.Types.SourceText import GHC.Types.Name.Occurrence import GHC.Types.SrcLoc +import GHC.Hs.Doc +import GHC.Hs.Extension import GHC.Utils.Outputable import GHC.Utils.Binary +import Language.Haskell.Syntax.Extension + import Data.Data -- | Warning Text -- -- reason/explanation from a WARNING or DEPRECATED pragma -data WarningTxt +data WarningTxt pass = WarningTxt (Located SourceText) - [Located StringLiteral] + [Located (WithHsDocIdentifiers StringLiteral pass)] | DeprecatedTxt (Located SourceText) - [Located StringLiteral] - deriving (Eq, Data) + [Located (WithHsDocIdentifiers StringLiteral pass)] + +deriving instance Eq (IdP pass) => Eq (WarningTxt pass) +deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) -instance Outputable WarningTxt where +instance Outputable (WarningTxt pass) where ppr (WarningTxt lsrc ws) = case unLoc lsrc of NoSourceText -> pp_ws ws @@ -45,7 +55,7 @@ instance Outputable WarningTxt where NoSourceText -> pp_ws ds SourceText src -> text src <+> pp_ws ds <+> text "#-}" -instance Binary WarningTxt where +instance Binary (WarningTxt GhcRn) where put_ bh (WarningTxt s w) = do putByte bh 0 put_ bh s @@ -66,7 +76,7 @@ instance Binary WarningTxt where return (DeprecatedTxt s d) -pp_ws :: [Located StringLiteral] -> SDoc +pp_ws :: [Located (WithHsDocIdentifiers StringLiteral pass)] -> SDoc pp_ws [l] = ppr $ unLoc l pp_ws ws = text "[" @@ -74,19 +84,19 @@ pp_ws ws <+> text "]" -pprWarningTxtForMsg :: WarningTxt -> SDoc +pprWarningTxtForMsg :: WarningTxt p -> SDoc pprWarningTxtForMsg (WarningTxt _ ws) - = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws)) + = doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ws)) pprWarningTxtForMsg (DeprecatedTxt _ ds) = text "Deprecated:" <+> - doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds)) + doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ds)) -- | Warning information for a module -data Warnings +data Warnings pass = NoWarnings -- ^ Nothing deprecated - | WarnAll WarningTxt -- ^ Whole module deprecated - | WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated + | WarnAll (WarningTxt pass) -- ^ Whole module deprecated + | WarnSome [(OccName,WarningTxt pass)] -- ^ Some specific things deprecated -- Only an OccName is needed because -- (1) a deprecation always applies to a binding @@ -108,9 +118,10 @@ data Warnings -- -- this is in contrast with fixity declarations, where we need to map -- a Name to its fixity declaration. - deriving( Eq ) -instance Binary Warnings where +deriving instance Eq (IdP pass) => Eq (Warnings pass) + +instance Binary (Warnings GhcRn) where put_ bh NoWarnings = putByte bh 0 put_ bh (WarnAll t) = do putByte bh 1 @@ -129,15 +140,15 @@ instance Binary Warnings where return (WarnSome aa) -- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' -mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt +mkIfaceWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p) mkIfaceWarnCache NoWarnings = \_ -> Nothing mkIfaceWarnCache (WarnAll t) = \_ -> Just t mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) -emptyIfaceWarnCache :: OccName -> Maybe WarningTxt +emptyIfaceWarnCache :: OccName -> Maybe (WarningTxt p) emptyIfaceWarnCache _ = Nothing -plusWarns :: Warnings -> Warnings -> Warnings +plusWarns :: Warnings p -> Warnings p -> Warnings p plusWarns d NoWarnings = d plusWarns NoWarnings d = d plusWarns _ (WarnAll t) = WarnAll t diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs index 36931b7b1f..15071c1b37 100644 --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -66,6 +66,8 @@ module GHC.Utils.Binary -- * Lazy Binary I/O lazyGet, lazyPut, + lazyGetMaybe, + lazyPutMaybe, -- * User data UserData(..), getUserData, setUserData, @@ -94,15 +96,19 @@ import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe as BS import Data.IORef import Data.Char ( ord, chr ) +import Data.List.NonEmpty ( NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Set ( Set ) +import qualified Data.Set as Set import Data.Time import Data.List (unfoldr) -import Data.Set (Set) -import qualified Data.Set as Set import Control.Monad ( when, (<$!>), unless, forM_ ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) import GHC.Real ( Ratio(..) ) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap #if MIN_VERSION_base(4,15,0) import GHC.ForeignPtr ( unsafeWithForeignPtr ) #endif @@ -635,9 +641,15 @@ instance Binary a => Binary [a] where loop n = do a <- get bh; as <- loop (n-1); return (a:as) loop len -instance Binary a => Binary (Set a) where - put_ bh a = put_ bh (Set.toAscList a) - get bh = Set.fromDistinctAscList <$> get bh +-- | This instance doesn't rely on the determinism of the keys' 'Ord' instance, +-- so it works e.g. for 'Name's too. +instance (Binary a, Ord a) => Binary (Set a) where + put_ bh s = put_ bh (Set.toList s) + get bh = Set.fromList <$> get bh + +instance Binary a => Binary (NonEmpty a) where + put_ bh = put_ bh . NonEmpty.toList + get bh = NonEmpty.fromList <$> get bh instance (Ix a, Binary a, Binary b) => Binary (Array a b) where put_ bh arr = do @@ -927,6 +939,25 @@ lazyGet bh = do seekBin bh p -- skip over the object for now return a +-- | Serialize the constructor strictly but lazily serialize a value inside a +-- 'Just'. +-- +-- This way we can check for the presence of a value without deserializing the +-- value itself. +lazyPutMaybe :: Binary a => BinHandle -> Maybe a -> IO () +lazyPutMaybe bh Nothing = putWord8 bh 0 +lazyPutMaybe bh (Just x) = do + putWord8 bh 1 + lazyPut bh x + +-- | Deserialize a value serialized by 'lazyPutMaybe'. +lazyGetMaybe :: Binary a => BinHandle -> IO (Maybe a) +lazyGetMaybe bh = do + h <- getWord8 bh + case h of + 0 -> pure Nothing + _ -> Just <$> lazyGet bh + -- ----------------------------------------------------------------------------- -- UserData -- ----------------------------------------------------------------------------- @@ -1323,3 +1354,11 @@ instance Binary SrcSpan where return (RealSrcSpan ss sb) _ -> do s <- get bh return (UnhelpfulSpan s) + +-------------------------------------------------------------------------------- +-- Instances for the containers package +-------------------------------------------------------------------------------- + +instance (Binary v) => Binary (IntMap v) where + put_ bh m = put_ bh (IntMap.toList m) + get bh = IntMap.fromList <$> get bh diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index f6a07ad0ae..06a784dba7 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -29,6 +29,7 @@ module GHC.Utils.Misc ( mapFst, mapSnd, chkAppend, mapAndUnzip, mapAndUnzip3, filterOut, partitionWith, + mapAccumM, dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, @@ -543,6 +544,15 @@ mapLastM _ [] = panic "mapLastM: empty list" mapLastM f [x] = (\x' -> [x']) <$> f x mapLastM f (x:xs) = (x:) <$> mapLastM f xs +mapAccumM :: (Monad m) => (r -> a -> m (r, b)) -> r -> [a] -> m (r, [b]) +mapAccumM f = go + where + go acc [] = pure (acc,[]) + go acc (x:xs) = do + (acc',y) <- f acc x + (acc'',ys) <- go acc' xs + pure (acc'', y:ys) + whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty [] _ = pure () whenNonEmpty (x:xs) f = f (x :| xs) diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs index b668d7fbff..64e9a0cc4e 100644 --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE ViewPatterns #-} @@ -150,7 +151,8 @@ data HsDecl p | RuleD (XRuleD p) (RuleDecls p) -- ^ Rule declaration | SpliceD (XSpliceD p) (SpliceDecl p) -- ^ Splice declaration -- (Includes quasi-quotes) - | DocD (XDocD p) (DocDecl) -- ^ Documentation comment declaration + | DocD (XDocD p) (DocDecl p) -- ^ Documentation comment + -- declaration | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration | XHsDecl !(XXHsDecl p) @@ -1064,8 +1066,8 @@ data ConDecl pass , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix , con_res_ty :: LHsType pass -- ^ Result type - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. + , con_doc :: Maybe (LHsDoc pass) -- ^ A possible Haddock + -- comment. } | ConDeclH98 @@ -1081,8 +1083,7 @@ data ConDecl pass , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) , con_args :: HsConDeclH98Details pass -- ^ Arguments; can be infix - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. + , con_doc :: Maybe (LHsDoc pass) -- ^ A possible Haddock comment. } | XConDecl !(XXConDecl pass) @@ -1706,21 +1707,22 @@ pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) -} -- | Located Documentation comment Declaration -type LDocDecl pass = XRec pass (DocDecl) +type LDocDecl pass = XRec pass (DocDecl pass) -- | Documentation comment Declaration -data DocDecl - = DocCommentNext HsDocString - | DocCommentPrev HsDocString - | DocCommentNamed String HsDocString - | DocGroup Int HsDocString - deriving Data +data DocDecl pass + = DocCommentNext (LHsDoc pass) + | DocCommentPrev (LHsDoc pass) + | DocCommentNamed String (LHsDoc pass) + | DocGroup Int (LHsDoc pass) + +deriving instance (Data pass, Data (IdP pass)) => Data (DocDecl pass) -- Okay, I need to reconstruct the document comments, but for now: -instance Outputable DocDecl where +instance Outputable (DocDecl name) where ppr _ = text "<document comment>" -docDeclDoc :: DocDecl -> HsDocString +docDeclDoc :: DocDecl pass -> LHsDoc pass docDeclDoc (DocCommentNext d) = d docDeclDoc (DocCommentPrev d) = d docDeclDoc (DocCommentNamed _ d) = d @@ -1751,9 +1753,10 @@ data WarnDecls pass = Warnings { wd_ext :: XWarnings pass type LWarnDecl pass = XRec pass (WarnDecl pass) -- | Warning pragma Declaration -data WarnDecl pass = Warning (XWarning pass) [LIdP pass] WarningTxt +data WarnDecl pass = Warning (XWarning pass) [LIdP pass] (WarningTxt pass) | XWarnDecl !(XXWarnDecl pass) + {- ************************************************************************ * * diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs index 10c2c03b48..e7c35f93c1 100644 --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -841,7 +841,7 @@ data HsType pass -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsDocTy (XDocTy pass) - (LHsType pass) LHsDocString -- A documented type + (LHsType pass) (LHsDoc pass) -- A documented type -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation @@ -1046,7 +1046,7 @@ data ConDeclField pass -- Record fields have Haddock docs on them cd_fld_names :: [LFieldOcc pass], -- ^ See Note [ConDeclField passs] cd_fld_type :: LBangType pass, - cd_fld_doc :: Maybe LHsDocString } + cd_fld_doc :: Maybe (LHsDoc pass)} -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 5a3794ee37..c02e56b291 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -420,6 +420,7 @@ Library GHC.Hs.Binds GHC.Hs.Decls GHC.Hs.Doc + GHC.Hs.DocString GHC.Hs.Dump GHC.Hs.Expr GHC.Hs.Syn.Type @@ -502,6 +503,7 @@ Library GHC.Parser.Errors.Types GHC.Parser.Header GHC.Parser.Lexer + GHC.Parser.HaddockLex GHC.Parser.PostProcess GHC.Parser.PostProcess.Haddock GHC.Parser.Types @@ -524,6 +526,7 @@ Library GHC.Plugins GHC.Prelude GHC.Rename.Bind + GHC.Rename.Doc GHC.Rename.Env GHC.Rename.Expr GHC.Rename.Fixity |