recursion-ninja pushed to branch wip/fix-26971 at Glasgow Haskell Compiler / GHC Commits: 273fba40 by Recursion Ninja at 2026-03-02T09:19:17-05:00 Adding WIP decoupling of L.H.S and GHC.Hs.Doc - - - - - 19 changed files: - compiler/GHC/Hs/Basic.hs - compiler/GHC/Hs/Doc.hs - − compiler/GHC/Hs/Doc.hs-boot - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Extension.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Decls.hs - + compiler/Language/Haskell/Syntax/Doc.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - + compiler/Language/Haskell/Syntax/UTF8.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Hs/Basic.hs ===================================== @@ -14,7 +14,7 @@ import GHC.Prelude import GHC.Utils.Outputable import GHC.Utils.Binary import GHC.Types.Name -import GHC.Parser.Annotation +--import GHC.Parser.Annotation import GHC.Utils.Misc ((<||>)) import Data.Data (Data) @@ -86,8 +86,8 @@ instance Binary FixityDirection where -- @ data NamespaceSpecifier = NoNamespaceSpecifier - | TypeNamespaceSpecifier (EpToken "type") - | DataNamespaceSpecifier (EpToken "data") + | TypeNamespaceSpecifier () -- (EpToken "type") + | DataNamespaceSpecifier () --(EpToken "data") deriving (Eq, Data) -- | Check if namespace specifiers overlap, i.e. if they are equal or ===================================== compiler/GHC/Hs/Doc.hs ===================================== @@ -32,6 +32,7 @@ import GHC.Data.EnumSet (EnumSet) import GHC.Types.Avail import GHC.Types.Name.Set import GHC.Driver.Flags +import GHC.Parser.Annotation import Control.DeepSeq import Data.Data @@ -49,29 +50,15 @@ import Data.Function import GHC.Hs.DocString +import Language.Haskell.Syntax.Doc import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name --- | A docstring with the (probable) identifiers found in it. -type HsDoc = WithHsDocIdentifiers HsDocString +deriving instance Eq a => Eq (WithHsDocIdentifiers a GhcPs) +deriving instance Eq a => Eq (WithHsDocIdentifiers a GhcRn) +deriving instance Eq a => Eq (WithHsDocIdentifiers a GhcTc) --- | 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. --- --- 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)] - } - -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 (NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where +instance (NFData (LIdP (GhcPass pass)), NFData a) => NFData (WithHsDocIdentifiers a (GhcPass pass)) where rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf i -- | For compatibility with the existing @-ddump-parsed' output, we only show @@ -81,12 +68,26 @@ instance (NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) w instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where ppr (WithHsDocIdentifiers s _ids) = ppr s -instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where +{- +instance forall a . (Binary a, Binary (Anno Name)) => Binary (WithHsDocIdentifiers a (GhcRn)) where put_ bh (WithHsDocIdentifiers s ids) = do put_ bh s - put_ bh $ BinLocated <$> (sortBy (stableNameCmp `on` getName) ids) + put_ bh $ BinGenLocated <$> ids +-- put_ bh ids get bh = - liftA2 WithHsDocIdentifiers (get bh) (fmap unBinLocated <$> get bh) + liftA2 (WithHsDocIdentifiers :: a -> [LIdP (GhcPass p)] -> WithHsDocIdentifiers a (GhcPass p)) (get bh) (fmap unBinGenLocated <$> get bh) +-} +{- +ids = [GenLocated (Anno Name) Name] + = [GenLocated (SrcSpanAnnN) Name] + = [GenLocated (EpAnn NameAnn) Name] + + +[LIdP GhcRn] = [XRec GhcRn (IdP GhcRn)] + = [XRec GhcRn (IdGhcP 'Renamed)] + = [XRec GhcRn Name] +-} + -- | Extract a mapping from the lexed identifiers to the names they may -- correspond to. @@ -98,22 +99,21 @@ hsDocIds (WithHsDocIdentifiers _ ids) = mkNameSet $ map unLoc ids -- 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 :: LHsDoc (GhcPass name) -> SDoc -> SDoc pprWithDoc doc = pprWithDocString (hsDocString $ unLoc doc) -- | See 'pprWithHsDoc' -pprMaybeWithDoc :: Maybe (LHsDoc name) -> SDoc -> SDoc +pprMaybeWithDoc :: Maybe (LHsDoc (GhcPass name)) -> SDoc -> SDoc pprMaybeWithDoc Nothing = id pprMaybeWithDoc (Just doc) = pprWithDoc doc -- | Print a doc with its identifiers, useful for debugging -pprHsDocDebug :: (Outputable (IdP name)) => HsDoc name -> SDoc +pprHsDocDebug :: HsDoc (GhcPass name) -> SDoc pprHsDocDebug (WithHsDocIdentifiers s ids) = vcat [ text "text:" $$ nest 2 (pprHsDocString s) - , text "identifiers:" $$ nest 2 (vcat (map pprLocatedAlways ids)) +-- , text "identifiers:" $$ nest 2 (vcat (map pprLocatedAlways ids)) ] - -type LHsDoc pass = Located (HsDoc pass) +-- XRec p (IdP p) -- | A simplified version of 'HsImpExp.IE'. data DocStructureItem @@ -136,6 +136,7 @@ data DocStructureItem -- ^ Invariant: This list of Avails must be sorted -- to guarantee interface file determinism. +{- instance Binary DocStructureItem where put_ bh = \case DsiSectionHeading level doc -> do @@ -165,6 +166,7 @@ instance Binary DocStructureItem where 3 -> DsiExports <$> get bh 4 -> DsiModExport <$> get bh <*> get bh _ -> fail "instance Binary DocStructureItem: Invalid tag" +-} instance Outputable DocStructureItem where ppr = \case @@ -185,8 +187,8 @@ instance Outputable DocStructureItem where instance NFData DocStructureItem where rnf = \case - DsiSectionHeading level doc -> rnf level `seq` rnf doc - DsiDocChunk doc -> rnf doc + DsiSectionHeading level !doc -> rnf level -- `seq` rnf doc + DsiDocChunk !doc -> () -- rnf doc DsiNamedChunkRef name -> rnf name DsiExports avails -> rnf avails DsiModExport mod_names avails -> rnf mod_names `seq` rnf avails @@ -220,10 +222,16 @@ data Docs = Docs instance NFData Docs where rnf (Docs mod_hdr exps decls args structure named_chunks haddock_opts language extentions) +{- = rnf mod_hdr `seq` rnf exps `seq` rnf decls `seq` rnf args `seq` rnf structure `seq` rnf named_chunks `seq` rnf haddock_opts `seq` rnf language `seq` rnf extentions `seq` () +-} + = rnf structure + `seq` rnf haddock_opts `seq` rnf language `seq` rnf extentions + `seq` () +{- instance Binary Docs where put_ bh docs = do put_ bh (docs_mod_hdr docs) @@ -255,6 +263,7 @@ instance Binary Docs where , docs_language = language , docs_extensions = exts } +-} instance Outputable Docs where ppr docs = ===================================== compiler/GHC/Hs/Doc.hs-boot deleted ===================================== @@ -1,18 +0,0 @@ -module GHC.Hs.Doc where - --- See #21592 for progress on removing this boot file. - -import GHC.Types.SrcLoc -import GHC.Hs.DocString -import Data.Kind - -type role WithHsDocIdentifiers representational nominal -type WithHsDocIdentifiers :: Type -> Type -> Type -data WithHsDocIdentifiers a pass - -type HsDoc :: Type -> Type -type HsDoc = WithHsDocIdentifiers HsDocString - -type LHsDoc :: Type -> Type -type LHsDoc pass = Located (HsDoc pass) - ===================================== compiler/GHC/Hs/DocString.hs ===================================== @@ -1,8 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} + -- | An exactprintable structure for docstrings module GHC.Hs.DocString ( LHsDocString , HsDocString(..) + , HsDocStringGhc , HsDocStringDecorator(..) , HsDocStringChunk(..) , LHsDocStringChunk @@ -23,6 +26,8 @@ module GHC.Hs.DocString import GHC.Prelude +import GHC.Hs.Extension + import GHC.Utils.Binary import GHC.Utils.Encoding import GHC.Utils.Outputable as Outputable hiding ((<>)) @@ -34,9 +39,16 @@ import qualified Data.ByteString as BS import Data.Data import Data.List.NonEmpty (NonEmpty(..)) import Data.List (intercalate) +import Data.Void + +import Language.Haskell.Syntax.Doc +import Language.Haskell.Syntax.Extension + +type LHsDocString pass = Located (HsDocString pass) -type LHsDocString = Located HsDocString +type HsDocStringGhc = HsDocString Void +{- -- | Haskell Documentation String -- -- Rich structure to support exact printing @@ -56,62 +68,81 @@ data HsDocString -- 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 +type instance XMultiLineDocString (GhcPass p) = NoExtField +type instance XNestedDocString (GhcPass p) = NoExtField +type instance XGeneratedDocString (GhcPass p) = NoExtField +type instance XXHsDocString (GhcPass p) = DataConCantHappen +{- instance NFData HsDocString where rnf (MultiLineDocString a b) = rnf a `seq` rnf b rnf (NestedDocString a b) = rnf a `seq` rnf b rnf (GeneratedDocString a) = rnf a +-} +deriving stock instance Eq (HsDocString (GhcPass pass)) +-- deriving stock instance Show (HsDocString (GhcPass pass)) --- | 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 +instance Binary (HsDocString (GhcPass p)) where put_ bh x = case x of - MultiLineDocString dec xs -> do + MultiLineDocString _ dec xs -> do putByte bh 0 put_ bh dec put_ bh $ BinLocated <$> xs - NestedDocString dec x -> do + NestedDocString _ dec x -> do putByte bh 1 put_ bh dec put_ bh $ BinLocated x - GeneratedDocString x -> do + GeneratedDocString _ x -> do putByte bh 2 put_ bh x get bh = do tag <- getByte bh case tag of - 0 -> MultiLineDocString <$> get bh <*> (fmap unBinLocated <$> get bh) - 1 -> NestedDocString <$> get bh <*> (unBinLocated <$> get bh) - 2 -> GeneratedDocString <$> get bh + 0 -> MultiLineDocString NoExtField <$> get bh <*> (fmap unBinLocated <$> get bh) + 1 -> NestedDocString NoExtField <$> get bh <*> (unBinLocated <$> get bh) + 2 -> GeneratedDocString NoExtField <$> get bh t -> fail $ "HsDocString: invalid tag " ++ show t +instance NFData (HsDocString (GhcPass pass)) where + rnf = \case + MultiLineDocString NoExtField a b -> rnf a `seq` rnf b + NestedDocString NoExtField a b -> rnf a `seq` rnf b + GeneratedDocString NoExtField a -> rnf a + +instance Outputable (HsDocString (GhcPass p)) 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 (GhcPass p) -> SDoc -> SDoc +pprWithDocString (MultiLineDocString x HsDocStringPrevious ds) sd = pprWithDocString (MultiLineDocString x HsDocStringNext ds) sd +pprWithDocString doc@(NestedDocString _ HsDocStringPrevious _) sd = sd <+> pprHsDocString doc +pprWithDocString doc sd = pprHsDocString doc $+$ sd + +{- 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 +{- instance NFData HsDocStringDecorator where rnf HsDocStringNext = () rnf HsDocStringPrevious = () rnf (HsDocStringNamed x) = rnf x rnf (HsDocStringGroup x) = rnf x +-} printDecorator :: HsDocStringDecorator -> String printDecorator HsDocStringNext = "|" @@ -134,20 +165,26 @@ instance Binary HsDocStringDecorator where 3 -> HsDocStringGroup <$> get bh t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t +{- type LHsDocStringChunk = Located HsDocStringChunk -- | A contiguous chunk of documentation newtype HsDocStringChunk = HsDocStringChunk ByteString deriving stock (Eq,Ord,Data, Show) deriving newtype (NFData) +-} + +type instance Anno HsDocStringChunk = SrcSpan 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 (utf8EncodeByteString s) @@ -163,41 +200,42 @@ 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 +isEmptyDocString :: HsDocString (GhcPass p) -> 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] +docStringChunks :: HsDocString (GhcPass p) -> [LHsDocStringChunk (GhcPass p)] +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 :: HsDocString (GhcPass p) -> SDoc pprHsDocString = text . exactPrintHsDocString -pprHsDocStrings :: [HsDocString] -> SDoc +pprHsDocStrings :: [HsDocString (GhcPass p)] -> 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)) +exactPrintHsDocString :: HsDocString (GhcPass p) -> String +exactPrintHsDocString (MultiLineDocString _ dec (x :| xs)) = unlines' $ ("-- " ++ printDecorator dec ++ unpackHDSC (unLoc x)) : map (\x -> "--" ++ unpackHDSC (unLoc x)) xs -exactPrintHsDocString (NestedDocString dec (L _ s)) +exactPrintHsDocString (NestedDocString _ dec (L _ s)) = "{-" ++ printDecorator dec ++ unpackHDSC s ++ "-}" -exactPrintHsDocString (GeneratedDocString x) = case lines (unpackHDSC x) of +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 +renderHsDocString :: HsDocString (GhcPass p) -> 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 @@ -205,5 +243,5 @@ unlines' = intercalate "\n" -- | Just get the docstring, without any decorators -- Separates docstrings using "\n\n", which is how haddock likes to render them -renderHsDocStrings :: [HsDocString] -> String +renderHsDocStrings :: [HsDocString (GhcPass p)] -> String renderHsDocStrings = intercalate "\n\n" . map renderHsDocString ===================================== compiler/GHC/Hs/Extension.hs ===================================== @@ -21,7 +21,7 @@ import GHC.Types.Var import GHC.Utils.Outputable hiding ((<>)) import GHC.Types.SrcLoc (GenLocated(..), unLoc) import GHC.Utils.Panic -import GHC.Parser.Annotation +--import GHC.Parser.Annotation {- Note [IsPass] @@ -92,16 +92,18 @@ type instance XRec (GhcPass p) a = XRecGhc a -- but pass-independent, source location type XRecGhc a = GenLocated (Anno a) a -type instance Anno RdrName = SrcSpanAnnN -type instance Anno Name = SrcSpanAnnN -type instance Anno Id = SrcSpanAnnN +--type instance Anno RdrName = SrcSpanAnnN +--type instance Anno Name = SrcSpanAnnN +--type instance Anno Id = SrcSpanAnnN type instance Anno (WithUserRdr a) = Anno a +{- type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ EpAnn a, Anno (IdOccGhcP p) ~ EpAnn a, NoAnn a, IsPass p) +-} instance UnXRec (GhcPass p) where unXRec = unLoc ===================================== compiler/GHC/Hs/ImpExp.hs ===================================== @@ -17,6 +17,7 @@ module GHC.Hs.ImpExp , module GHC.Hs.ImpExp ) where +import Language.Haskell.Syntax.Doc import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.ImpExp @@ -39,7 +40,6 @@ import GHC.Unit.Module.Warnings import Data.Data import Data.Maybe -import GHC.Hs.Doc (LHsDoc) {- @@ -144,6 +144,10 @@ simpleImportDecl mn = ImportDecl { } instance (OutputableBndrId p + , Outputable + (GenLocated + (Anno (WithHsDocIdentifiers (HsDocString (GhcPass p)) (GhcPass p))) + (WithHsDocIdentifiers (HsDocString (GhcPass p)) (GhcPass p))) , Outputable (Anno (IE (GhcPass p))) , Outputable (ImportDeclPkgQual (GhcPass p))) => Outputable (ImportDecl (GhcPass p)) where @@ -353,10 +357,10 @@ replaceWrappedName (IEData r (L l _)) n = IEData r (L l n) replaceLWrappedName :: LIEWrappedName GhcPs -> IdP GhcRn -> LIEWrappedName GhcRn replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') -exportDocstring :: LHsDoc pass -> SDoc +exportDocstring :: Outputable (LHsDoc (GhcPass p)) => LHsDoc (GhcPass p) -> SDoc exportDocstring doc = braces (text "docstring: " <> ppr doc) -instance OutputableBndrId p => Outputable (IE (GhcPass p)) where +instance (OutputableBndrId p, Outputable (LHsDoc (GhcPass p))) => Outputable (IE (GhcPass p)) where ppr ie@(IEVar _ var doc) = sep $ catMaybes [ ppr <$> ieDeprecation ie , Just $ ppr (unLoc var) ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Data.BooleanFormula (BooleanFormula(..)) import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Decls.Foreign (CType(..), Header(..)) import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) +import Language.Haskell.Syntax.Doc (HsDocString(..), WithHsDocIdentifiers(..)) import Language.Haskell.Syntax.Extension (Anno) import Language.Haskell.Syntax.Binds.InlinePragma (ActivationX(..), InlinePragma(..)) @@ -629,9 +630,9 @@ deriving instance Eq (IEWholeNamespaceExt GhcRn) deriving instance Eq (IEWholeNamespaceExt GhcTc) -- deriving instance (DataId name) => Data (IE name) -deriving instance Data (IE GhcPs) -deriving instance Data (IE GhcRn) -deriving instance Data (IE GhcTc) +deriving instance Data (Anno (WithHsDocIdentifiers (HsDocString GhcPs) GhcPs)) => Data (IE GhcPs) +deriving instance Data (Anno (WithHsDocIdentifiers (HsDocString GhcRn) GhcRn)) => Data (IE GhcRn) +deriving instance Data (Anno (WithHsDocIdentifiers (HsDocString GhcTc) GhcTc)) => Data (IE GhcTc) -- deriving instance (Eq name, Eq (IdP name)) => Eq (IE name) deriving instance Eq (IE GhcPs) @@ -669,3 +670,13 @@ deriving instance Data (InlinePragma GhcTc) deriving instance Data (OverlapMode GhcPs) deriving instance Data (OverlapMode GhcRn) deriving instance Data (OverlapMode GhcTc) + + +-- deriving instance Data (HsDocString p) +deriving instance Data (HsDocString GhcPs) +deriving instance Data (HsDocString GhcRn) +deriving instance Data (HsDocString GhcTc) + +deriving instance Data a => Data (WithHsDocIdentifiers a GhcPs) +deriving instance Data a => Data (WithHsDocIdentifiers a GhcRn) +deriving instance Data a => Data (WithHsDocIdentifiers a GhcTc) ===================================== compiler/GHC/Hs/Lit.hs ===================================== @@ -26,6 +26,7 @@ import GHC.Types.Basic (PprPrec(..), topPrec ) import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Types.SourceText import GHC.Core.Type +import GHC.Parser.Annotation ( {- type instance Anno Id -} ) import GHC.Utils.Misc (split) import GHC.Utils.Outputable import GHC.Utils.Panic (panic) ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -668,7 +668,7 @@ fromIfaceWarningTxt = \case IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs) fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn -fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names) +fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLocA names) fromIfaceStringLiteral :: IfaceStringLiteral -> StringLiteral fromIfaceStringLiteral (IfStringLiteral st fs) = StringLiteral st fs Nothing ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + module GHC.Parser.Annotation ( -- * Core Exact Print Annotation types EpToken(..), EpUniToken(..), @@ -32,6 +34,7 @@ module GHC.Parser.Annotation ( SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN, SrcSpanAnnLC, SrcSpanAnnLW, SrcSpanAnnLS, SrcSpanAnnLI, LocatedE, + IsSrcSpanAnn, -- ** Annotation data types used in 'GenLocated' @@ -94,17 +97,34 @@ import Data.Data import Data.Function (on) import Data.List (sortBy) import Data.Semigroup +import Data.Void import GHC.Data.FastString import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import GHC.Types.Name +import GHC.Types.Name.Reader (RdrName) import GHC.Types.SrcLoc -import GHC.Hs.DocString +--import GHC.Hs.DocString +import GHC.Types.Var (Id) import GHC.Utils.Misc import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic import qualified GHC.Data.Strict as Strict import GHC.Types.SourceText (SourceText (NoSourceText)) +import GHC.Hs.Extension + +import Language.Haskell.Syntax.Doc +import Language.Haskell.Syntax.Extension (Anno) + +type instance Anno Id = SrcSpanAnnN +type instance Anno Name = SrcSpanAnnN +type instance Anno RdrName = SrcSpanAnnN + +type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ EpAnn a, + Anno (IdOccGhcP p) ~ EpAnn a, + NoAnn a, + IsPass p) + {- Note [exact print annotations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -308,18 +328,46 @@ data EpaComment = -- and the start of this location is used for the spacing when -- exact printing the comment. } - deriving (Eq, Data, Show) + deriving (Eq, Show) + +instance Data EpaComment where + gunfold _ _ _ = undefined + toConstr = undefined + dataTypeOf = undefined data EpaCommentTok = -- Documentation annotations - EpaDocComment HsDocString -- ^ a docstring that can be pretty printed using pprHsDocString + EpaDocComment (HsDocString Void) -- ^ 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 {- -} - deriving (Eq, Data, Show) + deriving (Eq, Show) + -- TODO: add back the Data and Show instance -- 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 +instance {-# OVERLAPPING #-} Eq (HsDocString Void) where + (==) = \case + MultiLineDocString _ a1 b1 -> \case + MultiLineDocString _ a2 b2 -> a1 == a2 && length b1 == length b2 + _ -> False + NestedDocString _ a1 b1 -> \case + NestedDocString _ a2 b2 -> a1 == a2 + _ -> False + GeneratedDocString _ a1 -> \case + GeneratedDocString _ a2 -> a1 == a2 + _ -> False + XHsDocString _ -> \case + XHsDocString _ -> True + _ -> False + +instance {-# OVERLAPPING #-} Show (HsDocString Void) where + show = \case + MultiLineDocString _ a b -> unwords ["MultiLineDocString", show a ] + NestedDocString _ a b -> unwords ["NestedDocString" , show a ] + GeneratedDocString _ a -> unwords ["GeneratedDocString", show a ] + XHsDocString _ -> "XHsDocString" + instance Outputable EpaComment where ppr x = text (show x) @@ -390,7 +438,6 @@ data EpAnn ann deriving (Data, Eq, Functor) -- See Note [XRec and Anno in the AST] - spanAsAnchor :: SrcSpan -> (EpaLocation' a) spanAsAnchor ss = EpaSpan ss @@ -537,7 +584,7 @@ data AnnList a al_trailing :: ![TrailingAnn] -- ^ items appearing after the -- list, such as '=>' for a -- context - } deriving (Data,Eq) + } deriving (Data, Eq) data AnnListBrackets = ListParens (EpToken "(") (EpToken ")") @@ -570,7 +617,6 @@ data AnnContext ac_close :: [EpToken ")"] -- ^ zero or more closing parentheses. } deriving (Data) - -- --------------------------------------------------------------------- -- Annotations for names -- --------------------------------------------------------------------- @@ -648,7 +694,7 @@ data AnnPragma apr_loc2 :: EpaLocation, apr_type :: EpToken "type", apr_module :: EpToken "module" - } deriving (Data,Eq) + } deriving (Data, Eq) -- --------------------------------------------------------------------- ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -150,6 +150,10 @@ import qualified Data.Map.Strict as Map import qualified Data.Semigroup as S import System.IO.Unsafe ( unsafePerformIO ) +import Language.Haskell.Syntax.Extension + + + {- ************************************************************************ * * ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -103,7 +103,7 @@ module GHC.Utils.Binary getGenericSymtab, putGenericSymTab, getGenericSymbolTable, putGenericSymbolTable, -- * Newtype wrappers - BinSpan(..), BinSrcSpan(..), BinLocated(..), + BinSpan(..), BinSrcSpan(..), BinLocated(..), BinGenLocated(..), -- * Newtypes for types that have canonically more than one valid encoding BindingName(..), simpleBindingNameWriter, @@ -121,6 +121,7 @@ import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma import Language.Haskell.Syntax.Module.Name (ModuleName(..)) import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) +import Language.Haskell.Syntax.UTF8 import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.FastString @@ -1905,6 +1906,18 @@ instance Binary a => Binary (BinLocated a) where x <- get bh return $ BinLocated (L l x) +newtype BinGenLocated l a = BinGenLocated { unBinGenLocated :: GenLocated l a } + +instance (Binary a, Binary l) => Binary (BinGenLocated l a) where + put_ bh (BinGenLocated (L l x)) = do + put_ bh l + put_ bh x + + get bh = do + l <- get bh + x <- get bh + return $ BinGenLocated (L l x) + newtype BinSpan = BinSpan { unBinSpan :: RealSrcSpan } -- See Note [Source Location Wrappers] @@ -2097,3 +2110,8 @@ instance Binary RuleMatchInfo where h <- getByte bh if h == 1 then pure ConLike else pure FunLike + +instance Binary TextUTF8 where + put_ bh = putSBS bh . bytesUTF8 + + get = fmap unsafeFromShortByteString . getSBS ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -116,6 +116,7 @@ import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma import Language.Haskell.Syntax.Decls.Overlap ( OverlapMode(..) ) import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) +import Language.Haskell.Syntax.UTF8 import GHC.Prelude.Basic @@ -2036,3 +2037,6 @@ instance Outputable (OverlapMode p) where ppr (Incoherent _) = text "[incoherent]" ppr (NonCanonical _) = text "[noncanonical]" ppr (XOverlapMode _) = text "[user TTG extension]" + +instance Outputable TextUTF8 where + ppr = text . decodeUTF8 ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -1410,7 +1410,7 @@ data DocDecl pass | DocCommentNamed String (LHsDoc pass) | DocGroup Int (LHsDoc pass) -deriving instance (Data pass, Data (IdP pass)) => Data (DocDecl pass) +--deriving instance (Data pass, Data (IdP pass)) => Data (DocDecl pass) docDeclDoc :: DocDecl pass -> LHsDoc pass docDeclDoc (DocCommentNext d) = d ===================================== compiler/Language/Haskell/Syntax/Doc.hs ===================================== @@ -0,0 +1,172 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Eq XOverlapMode, NFData OverlapMode + +{- +## Migrate and restructure `LHsDoc` + +[X] 1. Create a new **`L.H.S.Doc`** module and move the following into it. +[X] 2. Move `HsDoc` *(no change)* +[X] 3. Move `HsDocStringChunk` *(no change)* +[X] 4. Move `HsDocStringDecorator` *(no change)* +[_] 5. Move `LHsDoc p` as `XRec p (HsDoc p)` +[X] 6. Move `WithHsDocIdentifiers p` as `Located (IdP p) as LIdP p` +[_] 7. Move `HsDocString`, adding TTG parameter and extension point +[X] 8. Move `LHsDocStringChunk = Located HsDocStringChunk` as `type LHsDocStringChunk pass = XRec pass HsDocStringChunk` +[ ] 9. Add `type instance Anno HsDocStringChunk = SrcSpan` +-} + +{- | +Data-types describing the raw and lexical docstrings of +the Haskell programming language. +-} +module Language.Haskell.Syntax.Doc + ( HsDoc + , WithHsDocIdentifiers(..) + + , HsDocString(..) + -- ** Construcction + , mkGeneratedHsDocString + + , HsDocStringChunk(..) + -- ** Construction + , mkHsDocStringChunk + , mkHsDocStringChunkUtf8ByteString + -- ** Deconstruction + , unpackHDSC + -- ** Query + , nullHDSC + + , HsDocStringDecorator(..) + , LHsDoc + , LHsDocStringChunk + ) where + +import Control.DeepSeq +import Data.ByteString (ByteString) +import qualified Data.ByteString.Short as SBS +import Data.Data +import Data.Kind (Type) +import Data.Eq +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Function +import Prelude +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.UTF8 + +-- | A docstring with the (probable) identifiers found in it. +type HsDoc (pass :: Type) = WithHsDocIdentifiers (HsDocString pass) pass + +-- | Haskell Documentation String +-- +-- Rich structure to support exact printing +-- The location around each chunk doesn't include the decorators +data HsDocString pass + = MultiLineDocString + !(XMultiLineDocString pass) + !HsDocStringDecorator + !(NonEmpty (LHsDocStringChunk pass)) + -- ^ 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 + !(XNestedDocString pass) + !HsDocStringDecorator + (LHsDocStringChunk pass) + -- ^ The docstring is preceded by "{-<decorator>" and followed by "-}" + -- The chunk contains balanced pairs of '{-' and '-}' + | GeneratedDocString + !(XGeneratedDocString pass) + 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' + | XHsDocString + !(XXHsDocString pass) +{- +deriving stock instance ( + Eq (XMultiLineDocString pass), + Eq (XNestedDocString pass), + Eq (XGeneratedDocString pass), + Eq (XXHsDocString pass), + Eq (XRec pass HsDocStringChunk), + Typeable pass + ) => Eq (HsDocString pass) + +deriving stock instance ( + Show (XMultiLineDocString pass), + Show (XNestedDocString pass), + Show (XGeneratedDocString pass), + Show (XXHsDocString pass), + Show (XRec pass HsDocStringChunk), + Typeable pass + ) => Show (HsDocString pass) + +instance {-# OVERLAPPABLE #-} ( + NFData (XMultiLineDocString pass), + NFData (XNestedDocString pass), + NFData (XGeneratedDocString pass), + NFData (XXHsDocString pass), + NFData (XRec pass HsDocStringChunk) + ) => NFData (HsDocString pass) where + rnf = \case + MultiLineDocString x a b -> rnf x `seq` rnf a `seq` rnf b + NestedDocString x a b -> rnf x `seq` rnf a `seq` rnf b + GeneratedDocString x a -> rnf x `seq` rnf a + XHsDocString x -> rnf x +-} +mkGeneratedHsDocString :: XGeneratedDocString p -> String -> HsDocString p +mkGeneratedHsDocString x = GeneratedDocString x . mkHsDocStringChunk + +type LHsDoc pass = XRec pass (HsDoc pass) +--type LHsDoc pass = Located (HsDoc pass) +--type LIdP p = XRec p (IdP p) + +type LHsDocStringChunk pass = XRec pass HsDocStringChunk + +-- | A contiguous chunk of documentation +newtype HsDocStringChunk = HsDocStringChunk TextUTF8 + deriving stock (Eq,Ord,Data, Show) + deriving newtype (NFData) + +mkHsDocStringChunk :: String -> HsDocStringChunk +mkHsDocStringChunk = HsDocStringChunk . encodeUTF8 + +mkHsDocStringChunkUtf8ByteString :: ByteString -> HsDocStringChunk +mkHsDocStringChunkUtf8ByteString = + HsDocStringChunk . unsafeFromShortByteString . SBS.toShort + +unpackHDSC :: HsDocStringChunk -> String +unpackHDSC (HsDocStringChunk bs) = decodeUTF8 bs + +nullHDSC :: HsDocStringChunk -> Bool +nullHDSC (HsDocStringChunk bs) = headUTF8 bs == Nothing + +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 NFData HsDocStringDecorator where + rnf HsDocStringNext = () + rnf HsDocStringPrevious = () + rnf (HsDocStringNamed x) = rnf x + rnf (HsDocStringGroup x) = rnf x + +-- | 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. +-- +-- 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 :: ![LIdP pass] + } ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -646,6 +646,13 @@ type family XXLit x type family XOverLit x type family XXOverLit x +-- ------------------------------------- +-- Type families for the HsDocString extension points +type family XMultiLineDocString x +type family XNestedDocString x +type family XGeneratedDocString x +type family XXHsDocString x + -- ===================================================================== -- Type families for the HsPat extension points ===================================== compiler/Language/Haskell/Syntax/ImpExp.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} module Language.Haskell.Syntax.ImpExp ( module Language.Haskell.Syntax.ImpExp, IsBootInterface(..) ) where +import Language.Haskell.Syntax.Doc import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) ) @@ -13,7 +14,7 @@ import Data.String (String) import Data.Int (Int) import Control.DeepSeq -import {-# SOURCE #-} GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST +--import {-# SOURCE #-} GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST {- ************************************************************************ ===================================== compiler/Language/Haskell/Syntax/UTF8.hs ===================================== @@ -0,0 +1,130 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +{- | +Represents a small chunk of UTF8 text from a source code file. +-} +module Language.Haskell.Syntax.UTF8 + ( + -- * Data-type + TextUTF8() + -- ** Construction + , encodeUTF8 + , unsafeFromShortByteString + -- ** Deconstruction + , bytesUTF8 + , byteStringUTF8 + , decodeUTF8 + , headUTF8 + -- ** Transformation + , linesUTF8 + , unlinesUTF8 + ) where + + +import Prelude + +import Control.DeepSeq +import Data.ByteString (StrictByteString) +import Data.ByteString.Short (ShortByteString(..)) +import qualified Data.ByteString.Short as SBS +import Data.Data +import Data.Foldable (toList) +import Data.String (IsString(..)) +import Data.Word (Word8) + +-- These is a modules are components of the @base@ package, +-- hence they do not directly couple the library to GHC. +import GHC.Base (Char(C#)) +import GHC.Encoding.UTF8 + +{- | +A UTF8 encoded ShortByteString representing the textual snippet of code +associated with a given element of the abstract syntax tree. +-} +newtype TextUTF8 = TextUTF8 { bytesUTF8 :: ShortByteString } + deriving (Data, Eq, Ord) + +instance IsString TextUTF8 where + fromString = encodeUTF8 + +instance NFData TextUTF8 where + rnf (TextUTF8 !sbs) = rnf sbs + +instance Semigroup TextUTF8 where + (TextUTF8 x) <> (TextUTF8 y) = TextUTF8 $ x <> y + +instance Monoid TextUTF8 where + mempty = TextUTF8 mempty + +instance Show TextUTF8 where + show (TextUTF8 sbs) = utf8DecodeShortByteString sbs + +{- | +Convert the UTF8 chunk of text to a 'ByteString'. + +_Time:_ $\mathcal{O}\left( n \right )$ +-} +byteStringUTF8 :: TextUTF8 -> StrictByteString +byteStringUTF8 (TextUTF8 sbs) = SBS.fromShort sbs + +{- | +Decode a UTF8 chunk of text to a 'String'. +-} +{-# INLINE decodeUTF8 #-} +decodeUTF8 :: TextUTF8 -> String +decodeUTF8 = utf8DecodeShortByteString . bytesUTF8 + +{- | +Encode a 'String' as a UTF8 chunk of text. +-} +{-# INLINE encodeUTF8 #-} +encodeUTF8 :: String -> TextUTF8 +encodeUTF8 = TextUTF8 . utf8EncodeShortByteString + +{- | +Extract the first code point from the UTF8 check of text. + +_Time:_ $\mathcal{O}\left( 1 \right )$ +-} +headUTF8 :: TextUTF8 -> Maybe Char +headUTF8 (TextUTF8 sbs@(SBS ba#)) + | SBS.length sbs == 0 = Nothing + | otherwise = + let !(# c#, _ #) = utf8DecodeCharByteArray# ba# 0# + in Just $ C# c# + +{- | +Split a UTF8 fragment of text on newline characters (@'\n'@). +-} +linesUTF8 :: TextUTF8 -> [TextUTF8] +linesUTF8 = fmap TextUTF8 . SBS.split newlineByte . bytesUTF8 + +{- | +Join a collection of UTF8 text fragments with newline characters (@'\n'@). +-} +unlinesUTF8 :: Foldable f => f TextUTF8 -> TextUTF8 +unlinesUTF8 = + TextUTF8 . SBS.intercalate (SBS.singleton newlineByte) . fmap bytesUTF8 . toList + +{- | +Assumes that the shortByteString is already UTF8 encoded. + +/This precondition is not checked!/ +-} +{-# INLINE unsafeFromShortByteString #-} +unsafeFromShortByteString :: ShortByteString -> TextUTF8 +unsafeFromShortByteString = TextUTF8 + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- +-- Internal Functionality +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +newlineByte :: Word8 +newlineByte = 0x0A -- 0x0A (10) is the new line character (\n) + +utf8DecodeShortByteString :: ShortByteString -> [Char] +utf8DecodeShortByteString (SBS ba#) = utf8DecodeByteArray# ba# + +utf8EncodeShortByteString :: String -> ShortByteString +utf8EncodeShortByteString str = SBS (utf8EncodeByteArray# str) ===================================== compiler/ghc.cabal.in ===================================== @@ -1028,6 +1028,7 @@ Library Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Decls.Foreign Language.Haskell.Syntax.Decls.Overlap + Language.Haskell.Syntax.Doc Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension Language.Haskell.Syntax.ImpExp @@ -1037,6 +1038,7 @@ Library Language.Haskell.Syntax.Pat Language.Haskell.Syntax.Specificity Language.Haskell.Syntax.Type + Language.Haskell.Syntax.UTF8 autogen-modules: GHC.Platform.Constants GHC.Settings.Config View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/273fba40c02500253e25b1f32da54889... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/273fba40c02500253e25b1f32da54889... You're receiving this email because of your account on gitlab.haskell.org.