diff options
| author | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2019-12-05 03:06:40 +0300 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2020-07-21 14:50:01 -0400 |
| commit | 19e80b9af252eee760dc047765a9930ef00067ec (patch) | |
| tree | cb45fce4b1e74e1a82c5bd926fda0e92de1964c1 | |
| parent | 58235d46bd4e9fbf69bd82969b29cd9c6ab051e1 (diff) | |
| download | haskell-19e80b9af252eee760dc047765a9930ef00067ec.tar.gz | |
Accumulate Haddock comments in P (#17544, #17561, #8944)
Haddock comments are, first and foremost, comments. It's very annoying
to incorporate them into the grammar. We can take advantage of an
important property: adding a Haddock comment does not change the parse
tree in any way other than wrapping some nodes in HsDocTy and the like
(and if it does, that's a bug).
This patch implements the following:
* Accumulate Haddock comments with their locations in the P monad.
This is handled in the lexer.
* After parsing, do a pass over the AST to associate Haddock comments
with AST nodes using location info.
* Report the leftover comments to the user as a warning (-Winvalid-haddock).
41 files changed, 3655 insertions, 626 deletions
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index f798051a56..8dfd865a2b 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -695,6 +695,7 @@ summariseRequirement pn mod_name = do ms_textual_imps = extra_sig_imports, ms_parsed_mod = Just (HsParsedModule { hpm_module = L loc (HsModule { + hsmodLayout = NoLayoutInfo, hsmodName = Just (L loc mod_name), hsmodExports = Nothing, hsmodImports = [], diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index a827ffe315..f5f642ce46 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -496,6 +496,7 @@ data WarningFlag = | Opt_WarnMissingSafeHaskellMode -- Since 8.10 | Opt_WarnCompatUnqualifiedImports -- Since 8.10 | Opt_WarnDerivingDefaults + | Opt_WarnInvalidHaddock -- Since 8.12 deriving (Eq, Show, Enum) -- | Used when outputting warnings: if a reason is given, it is diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 17e3796c3d..2982dbaefd 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -3450,7 +3450,8 @@ wWarningFlagsDeps = [ flagSpec "prepositive-qualified-module" Opt_WarnPrepositiveQualifiedModule, flagSpec "unused-packages" Opt_WarnUnusedPackages, - flagSpec "compat-unqualified-imports" Opt_WarnCompatUnqualifiedImports + flagSpec "compat-unqualified-imports" Opt_WarnCompatUnqualifiedImports, + flagSpec "invalid-haddock" Opt_WarnInvalidHaddock ] -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@ diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index 41876b8957..2512ba91cc 100644 --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -63,6 +63,9 @@ import Data.Data hiding ( Fixity ) -- All we actually declare here is the top-level structure for a module. data HsModule = HsModule { + hsmodLayout :: LayoutInfo, + -- ^ Layout info for the module. + -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo. hsmodName :: Maybe (Located ModuleName), -- ^ @Nothing@: \"module X where\" is omitted (in which case the next -- field is Nothing too) @@ -116,11 +119,11 @@ deriving instance Data HsModule instance Outputable HsModule where - ppr (HsModule Nothing _ imports decls _ mbDoc) + ppr (HsModule _ Nothing _ imports decls _ mbDoc) = pp_mb mbDoc $$ pp_nonnull imports $$ pp_nonnull decls - ppr (HsModule (Just name) exports imports decls deprec mbDoc) + ppr (HsModule _ (Just name) exports imports decls deprec mbDoc) = vcat [ pp_mb mbDoc, case exports of diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index c4d457d808..9759225109 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -92,6 +92,7 @@ module GHC.Hs.Decls ( HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls, hsGroupTopLevelFixitySigs, + partitionBindsAndSigs, ) where -- friends: @@ -219,6 +220,38 @@ Template Haskell `Dec`. If there are any duplicate signatures between the two fields, this will result in an error (#17608). -} +-- | Partition a list of HsDecls into function/pattern bindings, signatures, +-- type family declarations, type family instances, and documentation comments. +-- +-- Panics when given a declaration that cannot be put into any of the output +-- groups. +-- +-- The primary use of this function is to implement +-- 'GHC.Parser.PostProcess.cvBindsAndSigs'. +partitionBindsAndSigs + :: [LHsDecl GhcPs] + -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], + [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) +partitionBindsAndSigs = go + where + go [] = (emptyBag, [], [], [], [], []) + go ((L l decl) : ds) = + let (bs, ss, ts, tfis, dfis, docs) = go ds in + case decl of + ValD _ b + -> (L l b `consBag` bs, ss, ts, tfis, dfis, docs) + SigD _ s + -> (bs, L l s : ss, ts, tfis, dfis, docs) + TyClD _ (FamDecl _ t) + -> (bs, ss, L l t : ts, tfis, dfis, docs) + InstD _ (TyFamInstD { tfid_inst = tfi }) + -> (bs, ss, ts, L l tfi : tfis, dfis, docs) + InstD _ (DataFamInstD { dfid_inst = dfi }) + -> (bs, ss, ts, tfis, L l dfi : dfis, docs) + DocD _ d + -> (bs, ss, ts, tfis, dfis, L l d : docs) + _ -> pprPanic "partitionBindsAndSigs" (ppr decl) + -- | Haskell Group -- -- A 'HsDecl' is categorised into a 'HsGroup' before being @@ -643,10 +676,29 @@ type instance XDataDecl GhcPs = NoExtField type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn -type instance XClassDecl GhcPs = NoExtField +type instance XClassDecl GhcPs = LayoutInfo -- See Note [Class LayoutInfo] type instance XClassDecl GhcRn = NameSet -- FVs type instance XClassDecl GhcTc = NameSet -- FVs +{- Note [Class LayoutInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The LayoutInfo is used to associate Haddock comments with parts of the declaration. +Compare the following examples: + + class C a where + f :: a -> Int + -- ^ comment on f + + class C a where + f :: a -> Int + -- ^ comment on C + +Notice how "comment on f" and "comment on C" differ only by indentation level. +Thus we have to record the indentation level of the class declarations. + +See also Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock +-} + type instance XXTyClDecl (GhcPass _) = NoExtCon -- Simple classifiers for TyClDecl diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs index 9a5035b46e..55571c5128 100644 --- a/compiler/GHC/Hs/Doc.hs +++ b/compiler/GHC/Hs/Doc.hs @@ -7,6 +7,7 @@ module GHC.Hs.Doc , LHsDocString , mkHsDocString , mkHsDocStringUtf8ByteString + , isEmptyDocString , unpackHDS , hsDocStringToByteString , ppr_mbDoc @@ -64,6 +65,9 @@ instance Binary HsDocString where instance Outputable HsDocString where ppr = doubleQuotes . text . unpackHDS +isEmptyDocString :: HsDocString -> Bool +isEmptyDocString (HsDocString bs) = BS.null bs + mkHsDocString :: String -> HsDocString mkHsDocString s = inlinePerformIO $ do diff --git a/compiler/GHC/Hs/Stats.hs b/compiler/GHC/Hs/Stats.hs index 5b76372f37..9d7f8e8384 100644 --- a/compiler/GHC/Hs/Stats.hs +++ b/compiler/GHC/Hs/Stats.hs @@ -22,7 +22,7 @@ import Data.Char -- | Source Statistics ppSourceStats :: Bool -> Located HsModule -> SDoc -ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) +ppSourceStats short (L _ (HsModule{ hsmodExports = exports, hsmodImports = imports, hsmodDecls = ldecls })) = (if short then hcat else vcat) (map pp_val [("ExportAll ", export_all), -- 1 if no export list diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 8c9f0f8ef2..3043ba92b1 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -35,6 +35,7 @@ module GHC.Parser , parseTypeSignature , parseStmt, parseIdentifier , parseType, parseHeader + , parseModuleNoHaddock ) where @@ -73,6 +74,7 @@ import GHC.Types.SrcLoc import GHC.Unit.Module import GHC.Types.Basic import GHC.Types.ForeignCall +import GHC.Hs.Doc import GHC.Core.Type ( unrestrictedFunTyCon, Mult(..), Specificity(..) ) import GHC.Core.Class ( FunDep ) @@ -93,7 +95,7 @@ import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nil manyDataConTyCon) } -%expect 234 -- shift/reduce conflicts +%expect 232 -- shift/reduce conflicts {- Last updated: 08 June 2020 @@ -116,16 +118,6 @@ productions around in this file. ------------------------------------------------------------------------------- -state 0 contains 1 shift/reduce conflicts. - - Conflicts: DOCNEXT (empty missing_module_keyword reduces) - -Ambiguity when the source file starts with "-- | doc". We need another -token of lookahead to determine if a top declaration or the 'module' keyword -follows. Shift parses as if the 'module' keyword follows. - -------------------------------------------------------------------------------- - state 60 contains 1 shift/reduce conflict. context -> btype . @@ -607,11 +599,6 @@ are the most common patterns, rewritten as regular expressions for clarity: PRIMFLOAT { L _ (ITprimfloat _) } PRIMDOUBLE { L _ (ITprimdouble _) } - DOCNEXT { L _ (ITdocCommentNext _) } - DOCPREV { L _ (ITdocCommentPrev _) } - DOCNAMED { L _ (ITdocCommentNamed _) } - DOCSECTION { L _ (ITdocSection _ _) } - -- Template Haskell '[|' { L _ (ITopenExpQuote _ _) } '[p|' { L _ ITopenPatQuote } @@ -633,7 +620,7 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } %tokentype { (Located Token) } -- Exported parsers -%name parseModule module +%name parseModuleNoHaddock module %name parseSignature signature %name parseImport importdecl %name parseStatement e_stmt @@ -742,27 +729,25 @@ unitdecls :: { OrdList (LHsUnitDecl PackageName) } | unitdecl { unitOL $1 } unitdecl :: { LHsUnitDecl PackageName } - : maybedocheader 'module' maybe_src modid maybemodwarning maybeexports 'where' body + : 'module' maybe_src modid maybemodwarning maybeexports 'where' body -- XXX not accurate - { sL1 $2 $ DeclD - (case snd $3 of + { sL1 $1 $ DeclD + (case snd $2 of NotBoot -> HsSrcFile IsBoot -> HsBootFile) - $4 - (Just $ sL1 $2 (HsModule (Just $4) $6 (fst $ snd $8) (snd $ snd $8) $5 $1)) } - | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body - { sL1 $2 $ DeclD - HsigFile $3 - (Just $ sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1)) } - -- NB: MUST have maybedocheader here, otherwise shift-reduce conflict - -- will prevent us from parsing both forms. - | maybedocheader 'module' maybe_src modid - { sL1 $2 $ DeclD (case snd $3 of + (Just $ sL1 $1 (HsModule (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) } + | 'signature' modid maybemodwarning maybeexports 'where' body + { sL1 $1 $ DeclD + HsigFile + $2 + (Just $ sL1 $1 (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) } + | 'module' maybe_src modid + { sL1 $1 $ DeclD (case snd $2 of NotBoot -> HsSrcFile - IsBoot -> HsBootFile) $4 Nothing } - | maybedocheader 'signature' modid - { sL1 $2 $ DeclD HsigFile $3 Nothing } + IsBoot -> HsBootFile) $3 Nothing } + | 'signature' modid + { sL1 $1 $ DeclD HsigFile $2 Nothing } | 'dependency' unitid mayberns { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2 , idModRenaming = $3 @@ -783,29 +768,25 @@ unitdecl :: { LHsUnitDecl PackageName } -- know what they are doing. :-) signature :: { Located HsModule } - : maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body + : 'signature' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) - (snd $ snd $7) $4 $1) + ams (L loc (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) + (snd $ sndOf3 $6) $3 Nothing) ) - ([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) } + ([mj AnnSignature $1, mj AnnWhere $5] ++ fstOf3 $6) } module :: { Located HsModule } - : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body + : 'module' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) - (snd $ snd $7) $4 $1) + ams (L loc (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) + (snd $ sndOf3 $6) $3 Nothing) ) - ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) } + ([mj AnnModule $1, mj AnnWhere $5] ++ fstOf3 $6) } | body2 {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule Nothing Nothing - (fst $ snd $1) (snd $ snd $1) Nothing Nothing)) - (fst $1) } - -maybedocheader :: { Maybe LHsDocString } - : moduleheader { $1 } - | {- empty -} { Nothing } + ams (L loc (HsModule (thdOf3 $1) Nothing Nothing + (fst $ sndOf3 $1) (snd $ sndOf3 $1) Nothing Nothing)) + (fstOf3 $1) } missing_module_keyword :: { () } : {- empty -} {% pushModuleContext } @@ -823,16 +804,18 @@ maybemodwarning :: { Maybe (Located WarningTxt) } | {- empty -} { Nothing } body :: { ([AddAnn] - ,([LImportDecl GhcPs], [LHsDecl GhcPs])) } + ,([LImportDecl GhcPs], [LHsDecl GhcPs]) + ,LayoutInfo) } : '{' top '}' { (moc $1:mcc $3:(fst $2) - , snd $2) } - | vocurly top close { (fst $2, snd $2) } + , snd $2, ExplicitBraces) } + | vocurly top close { (fst $2, snd $2, VirtualBraces (getVOCURLY $1)) } body2 :: { ([AddAnn] - ,([LImportDecl GhcPs], [LHsDecl GhcPs])) } + ,([LImportDecl GhcPs], [LHsDecl GhcPs]) + ,LayoutInfo) } : '{' top '}' { (moc $1:mcc $3 - :(fst $2), snd $2) } - | missing_module_keyword top close { ([],snd $2) } + :(fst $2), snd $2, ExplicitBraces) } + | missing_module_keyword top close { ([],snd $2, VirtualBraces leftmostColumn) } top :: { ([AddAnn] @@ -848,17 +831,17 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) } -- Module declaration & imports only header :: { Located HsModule } - : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body + : 'module' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 - )) [mj AnnModule $2,mj AnnWhere $6] } - | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body + ams (L loc (HsModule NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing + )) [mj AnnModule $1,mj AnnWhere $5] } + | 'signature' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 - )) [mj AnnModule $2,mj AnnWhere $6] } + ams (L loc (HsModule NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing + )) [mj AnnModule $1,mj AnnWhere $5] } | header_body2 {% fileSrcSpan >>= \ loc -> - return (L loc (HsModule Nothing Nothing $1 [] Nothing + return (L loc (HsModule NoLayoutInfo Nothing Nothing $1 [] Nothing Nothing)) } header_body :: { [LImportDecl GhcPs] } @@ -885,26 +868,18 @@ maybeexports :: { (Maybe (Located [LIE GhcPs])) } | {- empty -} { Nothing } exportlist :: { OrdList (LIE GhcPs) } - : expdoclist ',' expdoclist {% addAnnotation (oll $1) AnnComma (gl $2) - >> return ($1 `appOL` $3) } - | exportlist1 { $1 } - -exportlist1 :: { OrdList (LIE GhcPs) } - : expdoclist export expdoclist ',' exportlist1 - {% (addAnnotation (oll ($1 `appOL` $2 `appOL` $3)) - AnnComma (gl $4) ) >> - return ($1 `appOL` $2 `appOL` $3 `appOL` $5) } - | expdoclist export expdoclist { $1 `appOL` $2 `appOL` $3 } - | expdoclist { $1 } + : exportlist1 { $1 } + | {- empty -} { nilOL } -expdoclist :: { OrdList (LIE GhcPs) } - : exp_doc expdoclist { $1 `appOL` $2 } - | {- empty -} { nilOL } + -- trailing comma: + | exportlist1 ',' { $1 } + | ',' { nilOL } -exp_doc :: { OrdList (LIE GhcPs) } - : docsection { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup noExtField n doc)) } - | docnamed { unitOL (sL1 $1 (IEDocNamed noExtField ((fst . unLoc) $1))) } - | docnext { unitOL (sL1 $1 (IEDoc noExtField (unLoc $1))) } +exportlist1 :: { OrdList (LIE GhcPs) } + : exportlist1 ',' export + {% (addAnnotation (oll $1) AnnComma (gl $2) ) >> + return ($1 `appOL` $3) } + | export { $1 } -- No longer allow things like [] and (,,,) to be exported @@ -1112,15 +1087,15 @@ topdecl :: { LHsDecl GhcPs } -- cl_decl :: { LTyClDecl GhcPs } : 'class' tycl_hdr fds where_cls - {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4)) - (mj AnnClass $1:(fst $ unLoc $3)++(fst $ unLoc $4)) } + {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4)) + (mj AnnClass $1:(fst $ unLoc $3)++(fstOf3 $ unLoc $4)) } -- Type declarations (toplevel) -- ty_decl :: { LTyClDecl GhcPs } -- ordinary type synonyms - : 'type' type '=' ktypedoc - -- Note ktypedoc, not sigtype, on the right of '=' + : 'type' type '=' ktype + -- Note ktype, not sigtype, on the right of '=' -- We allow an explicit for-all but we don't insert one -- in type Foo a = (b,b) -- Instead we just say b is out of scope @@ -1168,7 +1143,7 @@ ty_decl :: { LTyClDecl GhcPs } -- standalone kind signature standalone_kind_sig :: { LStandaloneKindSig GhcPs } - : 'type' sks_vars '::' ktypedoc + : 'type' sks_vars '::' ktype {% amms (mkStandaloneKindSig (comb2 $1 $4) $2 $4) [mj AnnType $1,mu AnnDcolon $3] } @@ -1538,7 +1513,7 @@ where_decls :: { Located ([AddAnn] ,sL1 $3 (snd $ unLoc $3)) } pattern_synonym_sig :: { LSig GhcPs } - : 'pattern' con_list '::' sigtypedoc + : 'pattern' con_list '::' sigtype {% ams (sLL $1 $> $ PatSynSig noExtField (unLoc $2) (mkLHsSigType $4)) [mj AnnPattern $1, mu AnnDcolon $3] } @@ -1552,7 +1527,7 @@ decl_cls : at_decl_cls { $1 } | decl { $1 } -- A 'default' signature used with the generic-programming extension - | 'default' infixexp '::' sigtypedoc + | 'default' infixexp '::' sigtype {% runECP_P $2 >>= \ $2 -> do { v <- checkValSigLhs $2 ; let err = text "in default signature" <> colon <+> @@ -1577,20 +1552,23 @@ decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed decllist_cls :: { Located ([AddAnn] - , OrdList (LHsDecl GhcPs)) } -- Reversed + , OrdList (LHsDecl GhcPs) + , LayoutInfo) } -- Reversed : '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) - ,snd $ unLoc $2) } - | vocurly decls_cls close { $2 } + ,snd $ unLoc $2, ExplicitBraces) } + | vocurly decls_cls close { let { L l (anns, decls) = $2 } + in L l (anns, decls, VirtualBraces (getVOCURLY $1)) } -- Class body -- where_cls :: { Located ([AddAnn] - ,(OrdList (LHsDecl GhcPs))) } -- Reversed + ,(OrdList (LHsDecl GhcPs)) -- Reversed + ,LayoutInfo) } -- No implicit parameters -- May have type declarations - : 'where' decllist_cls { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) - ,snd $ unLoc $2) } - | {- empty -} { noLoc ([],nilOL) } + : 'where' decllist_cls { sLL $1 $> (mj AnnWhere $1:(fstOf3 $ unLoc $2) + ,sndOf3 $ unLoc $2,thdOf3 $ unLoc $2) } + | {- empty -} { noLoc ([],nilOL,NoLayoutInfo) } -- Declarations in instance bodies -- @@ -1869,10 +1847,10 @@ safety :: { Located Safety } fspec :: { Located ([AddAnn] ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) } - : STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3] + : STRING var '::' sigtype { sLL $1 $> ([mu AnnDcolon $3] ,(L (getLoc $1) (getStringLiteral $1), $2, mkLHsSigType $4)) } - | var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2] + | var '::' sigtype { sLL $1 $> ([mu AnnDcolon $2] ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) } -- if the entity string is missing, it defaults to the empty string; -- the meaning of an empty entity string depends on the calling @@ -1892,10 +1870,6 @@ opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) } sigtype :: { LHsType GhcPs } : ctype { $1 } -sigtypedoc :: { LHsType GhcPs } - : ctypedoc { $1 } - - sig_vars :: { Located [Located RdrName] } -- Returned in reversed order : sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) @@ -1925,17 +1899,12 @@ forall_telescope :: { Located ([AddAnn], HsForAllTelescope GhcPs) } ( [mu AnnForall $1, mu AnnRarrow $3] , mkHsForAllVisTele req_tvbs ) }} --- A ktype/ktypedoc is a ctype/ctypedoc, possibly with a kind annotation +-- A ktype is a ctype, possibly with a kind annotation ktype :: { LHsType GhcPs } : ctype { $1 } | ctype '::' kind {% ams (sLL $1 $> $ HsKindSig noExtField $1 $3) [mu AnnDcolon $2] } -ktypedoc :: { LHsType GhcPs } - : ctypedoc { $1 } - | ctypedoc '::' kind {% ams (sLL $1 $> $ HsKindSig noExtField $1 $3) - [mu AnnDcolon $2] } - -- A ctype is a for-all type ctype :: { LHsType GhcPs } : forall_telescope ctype {% let (forall_anns, forall_tele) = unLoc $1 in @@ -1953,33 +1922,6 @@ ctype :: { LHsType GhcPs } [mu AnnDcolon $2] } | type { $1 } --- Note [ctype and ctypedoc] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- It would have been nice to simplify the grammar by unifying `ctype` and --- ctypedoc` into one production, allowing comments on types everywhere (and --- rejecting them after parsing, where necessary). This is however not possible --- since it leads to ambiguity. The reason is the support for comments on record --- fields: --- data R = R { field :: Int -- ^ comment on the field } --- If we allow comments on types here, it's not clear if the comment applies --- to 'field' or to 'Int'. So we must use `ctype` to describe the type. - -ctypedoc :: { LHsType GhcPs } - : forall_telescope ctypedoc {% let (forall_anns, forall_tele) = unLoc $1 in - ams (sLL $1 $> $ - HsForAllTy { hst_tele = forall_tele - , hst_xforall = noExtField - , hst_body = $2 }) - forall_anns } - | context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) - >> return (sLL $1 $> $ - HsQualTy { hst_ctxt = $1 - , hst_xqual = noExtField - , hst_body = $3 }) } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExtField $1 $3)) - [mu AnnDcolon $2] } - | typedoc { $1 } - ---------------------- -- Notes for 'context' -- We parse a context as a btype so that we don't get reduce/reduce @@ -1995,21 +1937,11 @@ context :: { LHsContext GhcPs } ; ams ctx anns } } --- See Note [Constr variations of non-terminals] -constr_context :: { LHsContext GhcPs } - : constr_btype {% do { (anns,ctx) <- checkContext $1 - ; if null (unLoc ctx) - then addAnnotation (gl $1) AnnUnit (gl $1) - else return () - ; ams ctx anns - } } - {- Note [GADT decl discards annotations] ~~~~~~~~~~~~~~~~~~~~~ The type production for - btype `->` ctypedoc - btype docprev `->` ctypedoc + btype `->` ctype add the AnnRarrow annotation twice, in different places. @@ -2035,53 +1967,12 @@ mult :: { LHsType GhcPs } : btype { $1 } -typedoc :: { LHsType GhcPs } - : btype { $1 } - | btype docprev { sLL $1 $> $ HsDocTy noExtField $1 $2 } - | docnext btype { sLL $1 $> $ HsDocTy noExtField $2 $1 } - | btype '->' ctypedoc {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ HsFunTy noExtField HsUnrestrictedArrow $1 $3) - [mu AnnRarrow $2] } - | btype docprev '->' ctypedoc {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ - HsFunTy noExtField HsUnrestrictedArrow - (L (comb2 $1 $2) (HsDocTy noExtField $1 $2)) $4) - [mu AnnRarrow $3] } - | btype '#->' ctypedoc {% hintLinear (getLoc $2) >> - ams (sLL $1 $> $ HsFunTy noExtField HsLinearArrow $1 $3) - [mu AnnRarrow $2] } - | btype docprev '#->' ctypedoc {% hintLinear (getLoc $2) >> - ams (sLL $1 $> $ - HsFunTy noExtField HsLinearArrow - (L (comb2 $1 $2) (HsDocTy noExtField $1 $2)) $4) - [mu AnnRarrow $3] } - | docnext btype '->' ctypedoc {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ - HsFunTy noExtField HsUnrestrictedArrow - (L (comb2 $1 $2) (HsDocTy noExtField $2 $1)) - $4) - [mu AnnRarrow $3] } - --- See Note [Constr variations of non-terminals] -constr_btype :: { LHsType GhcPs } - : constr_tyapps {% mergeOps (unLoc $1) } - --- See Note [Constr variations of non-terminals] -constr_tyapps :: { Located [Located TyEl] } -- NB: This list is reversed - : constr_tyapp { sL1 $1 [$1] } - | constr_tyapps constr_tyapp { sLL $1 $> $ $2 : (unLoc $1) } - --- See Note [Constr variations of non-terminals] -constr_tyapp :: { Located TyEl } - : tyapp { $1 } - | docprev { sL1 $1 $ TyElDocPrev (unLoc $1) } - btype :: { LHsType GhcPs } - : tyapps {% mergeOps $1 } + : tyapps {% mergeOps (unLoc $1) } -tyapps :: { [Located TyEl] } -- NB: This list is reversed - : tyapp { [$1] } - | tyapps tyapp { $2 : $1 } +tyapps :: { Located [Located TyEl] } -- NB: This list is reversed + : tyapp { sL1 $1 [$1] } + | tyapps tyapp { sLL $1 $> $ $2 : unLoc $1 } tyapp :: { Located TyEl } : atype { sL1 $1 $ TyElOpd (unLoc $1) } @@ -2162,9 +2053,9 @@ inst_type :: { LHsSigType GhcPs } : sigtype { mkLHsSigType $1 } deriv_types :: { [LHsSigType GhcPs] } - : ktypedoc { [mkLHsSigType $1] } + : ktype { [mkLHsSigType $1] } - | ktypedoc ',' deriv_types {% addAnnotation (gl $1) AnnComma (gl $2) + | ktype ',' deriv_types {% addAnnotation (gl $1) AnnComma (gl $2) >> return (mkLHsSigType $1 : $3) } comma_types0 :: { [LHsType GhcPs] } -- Zero or more: ty,ty,ty @@ -2266,10 +2157,10 @@ gadt_constrlist :: { Located ([AddAnn] | {- empty -} { noLoc ([],[]) } gadt_constrs :: { Located [LConDecl GhcPs] } - : gadt_constr_with_doc ';' gadt_constrs + : gadt_constr ';' gadt_constrs {% addAnnotation (gl $1) AnnSemi (gl $2) >> return (L (comb2 $1 $3) ($1 : unLoc $3)) } - | gadt_constr_with_doc { L (gl $1) [$1] } + | gadt_constr { L (gl $1) [$1] } | {- empty -} { noLoc [] } -- We allow the following forms: @@ -2278,19 +2169,12 @@ gadt_constrs :: { Located [LConDecl GhcPs] } -- D { x,y :: a } :: T a -- forall a. Eq a => D { x,y :: a } :: T a -gadt_constr_with_doc :: { LConDecl GhcPs } -gadt_constr_with_doc - : maybe_docnext ';' gadt_constr - {% return $ addConDoc $3 $1 } - | gadt_constr - {% return $1 } - gadt_constr :: { LConDecl GhcPs } -- see Note [Difference in parsing GADT and data constructors] -- Returns a list because of: C,D :: ty - : con_list '::' sigtypedoc - {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) $3)) - [mu AnnDcolon $2] } + : optSemi con_list '::' sigtype + {% ams (sLL $2 $> (mkGadtDecl (unLoc $2) $4)) + [mu AnnDcolon $3] } {- Note [Difference in parsing GADT and data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2305,91 +2189,36 @@ allowed in usual data constructors, but not in GADTs). -} constrs :: { Located ([AddAnn],[LConDecl GhcPs]) } - : maybe_docnext '=' constrs1 { L (comb2 $2 $3) ([mj AnnEqual $2] - ,addConDocs (unLoc $3) $1)} + : '=' constrs1 { sLL $1 $2 ([mj AnnEqual $1],unLoc $2)} constrs1 :: { Located [LConDecl GhcPs] } - : constrs1 maybe_docnext '|' maybe_docprev constr - {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $3) - >> return (sLL $1 $> (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4)) } + : constrs1 '|' constr + {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) + >> return (sLL $1 $> ($3 : unLoc $1)) } | constr { sL1 $1 [$1] } -{- Note [Constr variations of non-terminals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In record declarations we assume that 'ctype' used to parse the type will not -consume the trailing docprev: - - data R = R { field :: Int -- ^ comment on the field } - -In 'R' we expect the comment to apply to the entire field, not to 'Int'. The -same issue is detailed in Note [ctype and ctypedoc]. - -So, we do not want 'ctype' to consume 'docprev', therefore - we do not want 'btype' to consume 'docprev', therefore - we do not want 'tyapps' to consume 'docprev'. - -At the same time, when parsing a 'constr', we do want to consume 'docprev': - - data T = C Int -- ^ comment on Int - Bool -- ^ comment on Bool - -So, we do want 'constr_stuff' to consume 'docprev'. - -The problem arises because the clauses in 'constr' have the following -structure: - - (a) context '=>' constr_stuff (e.g. data T a = Ord a => C a) - (b) constr_stuff (e.g. data T a = C a) - -and to avoid a reduce/reduce conflict, 'context' and 'constr_stuff' must be -compatible. And for 'context' to be compatible with 'constr_stuff', it must -consume 'docprev'. - -So, we want 'context' to consume 'docprev', therefore - we want 'btype' to consume 'docprev', therefore - we want 'tyapps' to consume 'docprev'. - -Our requirements end up conflicting: for parsing record types, we want 'tyapps' -to leave 'docprev' alone, but for parsing constructors, we want it to consume -'docprev'. - -As the result, we maintain two parallel hierarchies of non-terminals that -either consume 'docprev' or not: - - tyapps constr_tyapps - btype constr_btype - context constr_context - ... - -They must be kept identical except for their treatment of 'docprev'. - --} - constr :: { LConDecl GhcPs } - : maybe_docnext forall constr_context '=>' constr_stuff - {% ams (let (con,details,doc_prev) = unLoc $5 in - addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con - (snd $ unLoc $2) - (Just $3) - details)) - ($1 `mplus` doc_prev)) - (mu AnnDarrow $4:(fst $ unLoc $2)) } - | maybe_docnext forall constr_stuff - {% ams ( let (con,details,doc_prev) = unLoc $3 in - addConDoc (L (comb2 $2 $3) (mkConDeclH98 con - (snd $ unLoc $2) - Nothing -- No context - details)) - ($1 `mplus` doc_prev)) - (fst $ unLoc $2) } + : forall context '=>' constr_stuff + {% ams (let (con,details) = unLoc $4 in + (L (comb4 $1 $2 $3 $4) (mkConDeclH98 con + (snd $ unLoc $1) + (Just $2) + details))) + (mu AnnDarrow $3:(fst $ unLoc $1)) } + | forall constr_stuff + {% ams (let (con,details) = unLoc $2 in + (L (comb2 $1 $2) (mkConDeclH98 con + (snd $ unLoc $1) + Nothing -- No context + details))) + (fst $ unLoc $1) } forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) } : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) } | {- empty -} { noLoc ([], Nothing) } -constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString) } - : constr_tyapps {% do { c <- mergeDataCon (unLoc $1) +constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs) } + : tyapps {% do { c <- mergeDataCon (unLoc $1) ; return $ sL1 $1 c } } fielddecls :: { [LConDeclField GhcPs] } @@ -2397,17 +2226,17 @@ fielddecls :: { [LConDeclField GhcPs] } | fielddecls1 { $1 } fielddecls1 :: { [LConDeclField GhcPs] } - : fielddecl maybe_docnext ',' maybe_docprev fielddecls1 - {% addAnnotation (gl $1) AnnComma (gl $3) >> - return ((addFieldDoc $1 $4) : addFieldDocs $5 $2) } + : fielddecl ',' fielddecls1 + {% addAnnotation (gl $1) AnnComma (gl $2) >> + return ($1 : $3) } | fielddecl { [$1] } fielddecl :: { LConDeclField GhcPs } -- A list because of f,g :: Int - : maybe_docnext sig_vars '::' ctype maybe_docprev - {% ams (L (comb2 $2 $4) - (ConDeclField noExtField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExtField ln) (unLoc $2))) $4 ($1 `mplus` $5))) - [mu AnnDcolon $3] } + : sig_vars '::' ctype + {% ams (L (comb2 $1 $3) + (ConDeclField noExtField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing)) + [mu AnnDcolon $2] } -- Reversed! maybe_derivings :: { HsDeriving GhcPs } @@ -2438,7 +2267,8 @@ deriving :: { LHsDerivingClause GhcPs } [mj AnnDeriving $1] } deriv_clause_types :: { Located [LHsSigType GhcPs] } - : qtycondoc { sL1 $1 [mkLHsSigType $1] } + : qtycon { let { tc = sL1 $1 (HsTyVar noExtField NotPromoted $1) } in + sL1 $1 [mkLHsSigType tc] } | '(' ')' {% ams (sLL $1 $> []) [mop $1,mcp $2] } | '(' deriv_types ')' {% ams (sLL $1 $> $2) @@ -2471,15 +2301,6 @@ There's an awkward overlap with a type signature. Consider We can't tell whether to reduce var to qvar until after we've read the signatures. -} -docdecl :: { LHsDecl GhcPs } - : docdecld { sL1 $1 (DocD noExtField (unLoc $1)) } - -docdecld :: { LDocDecl } - : docnext { sL1 $1 (DocCommentNext (unLoc $1)) } - | docprev { sL1 $1 (DocCommentPrev (unLoc $1)) } - | docnamed { sL1 $1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) } - | docsection { sL1 $1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) } - decl_no_th :: { LHsDecl GhcPs } : sigdecl { $1 } @@ -2497,7 +2318,6 @@ decl_no_th :: { LHsDecl GhcPs } _ <- amsL l (ann ++ (fst $ unLoc $3)); return $! (sL l $ ValD noExtField r) } } | pattern_synonym_decl { $1 } - | docdecl { $1 } decl :: { LHsDecl GhcPs } : decl_no_th { $1 } @@ -2529,14 +2349,14 @@ gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) } sigdecl :: { LHsDecl GhcPs } : -- See Note [Declaration/signature overlap] for why we need infixexp here - infixexp '::' sigtypedoc + infixexp '::' sigtype {% do { $1 <- runECP_P $1 ; v <- checkValSigLhs $1 ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2] ; return (sLL $1 $> $ SigD noExtField $ TypeSig noExtField [v] (mkLHsSigWcType $3))} } - | var ',' sig_vars '::' sigtypedoc + | var ',' sig_vars '::' sigtype {% do { let sig = TypeSig noExtField ($1 : reverse (unLoc $3)) (mkLHsSigWcType $5) ; addAnnotation (gl $1) AnnComma (gl $2) @@ -3581,10 +3401,6 @@ qtycon :: { Located RdrName } -- Qualified or unqualified : QCONID { sL1 $1 $! mkQual tcClsName (getQCONID $1) } | tycon { $1 } -qtycondoc :: { LHsType GhcPs } -- Qualified or unqualified - : qtycon { sL1 $1 (HsTyVar noExtField NotPromoted $1) } - | qtycon docprev { sLL $1 $> (HsDocTy noExtField (sL1 $1 (HsTyVar noExtField NotPromoted $1)) $2) } - tycon :: { Located RdrName } -- Unqualified : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) } @@ -3824,37 +3640,6 @@ bars :: { ([SrcSpan],Int) } -- One or more bars : bars '|' { ((fst $1)++[gl $2],snd $1 + 1) } | '|' { ([gl $1],1) } ------------------------------------------------------------------------------ --- Documentation comments - -docnext :: { LHsDocString } - : DOCNEXT {% return (sL1 $1 (mkHsDocString (getDOCNEXT $1))) } - -docprev :: { LHsDocString } - : DOCPREV {% return (sL1 $1 (mkHsDocString (getDOCPREV $1))) } - -docnamed :: { Located (String, HsDocString) } - : DOCNAMED {% - let string = getDOCNAMED $1 - (name, rest) = break isSpace string - in return (sL1 $1 (name, mkHsDocString rest)) } - -docsection :: { Located (Int, HsDocString) } - : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in - return (sL1 $1 (n, mkHsDocString doc)) } - -moduleheader :: { Maybe LHsDocString } - : DOCNEXT {% let string = getDOCNEXT $1 in - return (Just (sL1 $1 (mkHsDocString string))) } - -maybe_docprev :: { Maybe LHsDocString } - : docprev { Just $1 } - | {- empty -} { Nothing } - -maybe_docnext :: { Maybe LHsDocString } - : docnext { Just $1 } - | {- empty -} { Nothing } - { happyError :: P a happyError = srcParseFail @@ -3885,11 +3670,7 @@ getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x - -getDOCNEXT (L _ (ITdocCommentNext x)) = x -getDOCPREV (L _ (ITdocCommentPrev x)) = x -getDOCNAMED (L _ (ITdocCommentNamed x)) = x -getDOCSECTION (L _ (ITdocSection n x)) = (n, x) +getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l getINTEGERs (L _ (ITinteger (IL src _ _))) = src getCHARs (L _ (ITchar src _)) = src @@ -4209,4 +3990,16 @@ oll l = asl :: [Located a] -> Located b -> Located a -> P () asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls + +-- | Parse a Haskell module with Haddock comments. +-- This is done in two steps: +-- +-- * 'parseModuleNoHaddock' to build the AST +-- * 'addHaddockToModule' to insert Haddock comments into it +-- +-- This is the only parser entry point that deals with Haddock comments. +-- The other entry points ('parseDeclaration', 'parseExpression', etc) do +-- not insert them into the AST. +parseModule :: P (Located HsModule) +parseModule = parseModuleNoHaddock >>= addHaddockToModule } diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index ef9f1803bf..7265e1dffb 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -66,7 +66,8 @@ module GHC.Parser.Lexer ( lexTokenStream, AddAnn(..),mkParensApiAnn, addAnnsAt, - commentToAnnotation + commentToAnnotation, + HdkComment(..), ) where import GHC.Prelude @@ -97,6 +98,8 @@ import GHC.Utils.Outputable import GHC.Data.StringBuffer import GHC.Data.FastString import GHC.Types.Unique.FM +import GHC.Data.Maybe +import GHC.Data.OrdList import GHC.Utils.Misc ( readRational, readHexRational ) -- compiler/main @@ -109,6 +112,7 @@ import GHC.Unit import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..), IntegralLit(..), FractionalLit(..), SourceText(..) ) +import GHC.Hs.Doc -- compiler/parser import GHC.Parser.CharClass @@ -363,10 +367,8 @@ $tab { warnTab } -- Haddock comments -<0,option_prags> { - "-- " $docsym / { ifExtension HaddockBit } { multiline_doc_comment } - "{-" \ ? $docsym / { ifExtension HaddockBit } { nested_doc_comment } -} +"-- " $docsym / { ifExtension HaddockBit } { multiline_doc_comment } +"{-" \ ? $docsym / { ifExtension HaddockBit } { nested_doc_comment } -- "special" symbols @@ -1271,11 +1273,8 @@ nested_comment cont span buf len = do go (reverse $ lexemeToString buf len) (1::Int) input where go commentAcc 0 input = do - setInput input - b <- getBit RawTokenStreamBit - if b - then docCommentEnd input commentAcc ITblockComment buf span - else cont + let finalizeComment str = (Nothing, ITblockComment str) + commentEnd cont input commentAcc finalizeComment buf span go commentAcc n input = case alexGetChar' input of Nothing -> errBrace input (psRealSpan span) Just ('-',input) -> case alexGetChar' input of @@ -1365,24 +1364,37 @@ return control to parseNestedPragma by returning the ITcomment_line_prag token. See #314 for more background on the bug this fixes. -} -withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (PsLocated Token)) +withLexedDocType :: (AlexInput -> (String -> (HdkComment, Token)) -> Bool -> P (PsLocated Token)) -> P (PsLocated Token) withLexedDocType lexDocComment = do input@(AI _ buf) <- getInput case prevChar buf ' ' of -- The `Bool` argument to lexDocComment signals whether or not the next -- line of input might also belong to this doc comment. - '|' -> lexDocComment input ITdocCommentNext True - '^' -> lexDocComment input ITdocCommentPrev True - '$' -> lexDocComment input ITdocCommentNamed True + '|' -> lexDocComment input mkHdkCommentNext True + '^' -> lexDocComment input mkHdkCommentPrev True + '$' -> lexDocComment input mkHdkCommentNamed True '*' -> lexDocSection 1 input _ -> panic "withLexedDocType: Bad doc type" where lexDocSection n input = case alexGetChar' input of Just ('*', input) -> lexDocSection (n+1) input - Just (_, _) -> lexDocComment input (ITdocSection n) False + Just (_, _) -> lexDocComment input (mkHdkCommentSection n) False Nothing -> do setInput input; lexToken -- eof reached, lex it normally +mkHdkCommentNext, mkHdkCommentPrev :: String -> (HdkComment, Token) +mkHdkCommentNext str = (HdkCommentNext (mkHsDocString str), ITdocCommentNext str) +mkHdkCommentPrev str = (HdkCommentPrev (mkHsDocString str), ITdocCommentPrev str) + +mkHdkCommentNamed :: String -> (HdkComment, Token) +mkHdkCommentNamed str = + let (name, rest) = break isSpace str + in (HdkCommentNamed name (mkHsDocString rest), ITdocCommentNamed str) + +mkHdkCommentSection :: Int -> String -> (HdkComment, Token) +mkHdkCommentSection n str = + (HdkCommentSection n (mkHsDocString str), ITdocSection n str) + -- RULES pragmas turn on the forall and '.' keywords, and we turn them -- off again at the end of the pragma. rulePrag :: Action @@ -1425,17 +1437,34 @@ 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. -docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> - PsSpan -> P (PsLocated Token) -docCommentEnd input commentAcc docType buf span = do +commentEnd :: P (PsLocated Token) + -> AlexInput + -> String + -> (String -> (Maybe HdkComment, Token)) + -> StringBuffer + -> PsSpan + -> P (PsLocated Token) +commentEnd cont input commentAcc finalizeComment 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 - return (L span' (docType comment)) + 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 -> + 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 errBrace :: AlexInput -> RealSrcSpan -> P a errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) "unterminated `{-'" @@ -2170,6 +2199,15 @@ data ParserFlags = ParserFlags { , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions } +-- | Haddock comment as produced by the lexer. These are accumulated in +-- 'PState' and then processed in "GHC.Parser.PostProcess.Haddock". +data HdkComment + = HdkCommentNext HsDocString + | HdkCommentPrev HsDocString + | HdkCommentNamed String HsDocString + | HdkCommentSection Int HsDocString + deriving Show + data PState = PState { buffer :: StringBuffer, options :: ParserFlags, @@ -2211,7 +2249,13 @@ data PState = PState { annotations :: [(ApiAnnKey,[RealSrcSpan])], eof_pos :: Maybe RealSrcSpan, comment_q :: [RealLocated AnnotationComment], - annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])] + annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])], + + -- Haddock comments accumulated in ascending order of their location + -- (BufPos). We use OrdList to get O(1) snoc. + -- + -- See Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock + hdk_comments :: OrdList (PsLocated HdkComment) } -- last_loc and last_len are used when generating error messages, -- and in pushCurrentContext only. Sigh, if only Happy passed the @@ -2698,7 +2742,8 @@ mkPStatePure options buf loc = annotations = [], eof_pos = Nothing, comment_q = [], - annotations_comments = [] + annotations_comments = [], + hdk_comments = nilOL } where init_loc = PsLoc loc (BufPos 0) @@ -2917,10 +2962,6 @@ lexer queueComments cont = do (L span tok) <- lexTokenFun --trace ("token: " ++ show tok) $ do - if (queueComments && isDocComment tok) - then queueComment (L (psRealSpan span) tok) - else return () - if (queueComments && isComment tok) then queueComment (L (psRealSpan span) tok) >> lexer queueComments cont else cont (L (mkSrcSpanPs span) tok) @@ -3372,13 +3413,10 @@ commentToAnnotation _ = panic "commentToAnnotation" 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 - -isDocComment :: Token -> Bool -isDocComment (ITdocCommentNext _) = True -isDocComment (ITdocCommentPrev _) = True -isDocComment (ITdocCommentNamed _) = True -isDocComment (ITdocSection _ _) = True -isDocComment (ITdocOptions _) = True -isDocComment _ = False } diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 398bd78ddc..3cf5b30b06 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -126,7 +126,6 @@ import GHC.Builtin.Names ( allNameStrings ) import GHC.Types.SrcLoc import GHC.Types.Unique ( hasKey ) import GHC.Data.OrdList ( OrdList, fromOL ) -import GHC.Data.Bag ( emptyBag, consBag ) import GHC.Utils.Outputable as Outputable import GHC.Data.FastString import GHC.Data.Maybe @@ -172,16 +171,18 @@ mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a,[LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) + -> LayoutInfo -> P (LTyClDecl GhcPs) -mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls +mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls ; let cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan - ; return (L loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt + ; return (L loc (ClassDecl { tcdCExt = layoutInfo + , tcdCtxt = cxt , tcdLName = cls, tcdTyVars = tyvars , tcdFixity = fixity , tcdFDs = snd (unLoc fds) @@ -418,14 +419,7 @@ fromSpecTyVarBndr bndr = case bndr of -- | Groups together bindings for a single function cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] -cvTopDecls decls = go (fromOL decls) - where - go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] - go [] = [] - go ((L l (ValD x b)) : ds) - = L l' (ValD x b') : go ds' - where (L l' b', ds') = getMonoBind (L l b) ds - go (d : ds) = d : go ds +cvTopDecls decls = getMonoBindAll (fromOL decls) -- Declaration list may only contain value bindings and signatures. cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) @@ -441,33 +435,32 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -- Input decls contain just value bindings and signatures -- and in case of class or instance declarations also -- associated type declarations. They might also contain Haddock comments. -cvBindsAndSigs fb = go (fromOL fb) +cvBindsAndSigs fb = do + fb' <- drop_bad_decls (fromOL fb) + return (partitionBindsAndSigs (getMonoBindAll fb')) where - go [] = return (emptyBag, [], [], [], [], []) - go ((L l (ValD _ b)) : ds) - = do { (bs, ss, ts, tfis, dfis, docs) <- go ds' - ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) } - where - (b', ds') = getMonoBind (L l b) ds - go ((L l decl) : ds) - = do { (bs, ss, ts, tfis, dfis, docs) <- go ds - ; case decl of - SigD _ s - -> return (bs, L l s : ss, ts, tfis, dfis, docs) - TyClD _ (FamDecl _ t) - -> return (bs, ss, L l t : ts, tfis, dfis, docs) - InstD _ (TyFamInstD { tfid_inst = tfi }) - -> return (bs, ss, ts, L l tfi : tfis, dfis, docs) - InstD _ (DataFamInstD { dfid_inst = dfi }) - -> return (bs, ss, ts, tfis, L l dfi : dfis, docs) - DocD _ d - -> return (bs, ss, ts, tfis, dfis, L l d : docs) - SpliceD _ d - -> addFatalError l $ - hang (text "Declaration splices are allowed only" <+> - text "at the top level:") - 2 (ppr d) - _ -> pprPanic "cvBindsAndSigs" (ppr decl) } + -- cvBindsAndSigs is called in several places in the parser, + -- and its items can be produced by various productions: + -- + -- * decl (when parsing a where clause or a let-expression) + -- * decl_inst (when parsing an instance declaration) + -- * decl_cls (when parsing a class declaration) + -- + -- partitionBindsAndSigs can handle almost all declaration forms produced + -- by the aforementioned productions, except for SpliceD, which we filter + -- out here (in drop_bad_decls). + -- + -- We're not concerned with every declaration form possible, such as those + -- produced by the topdecl parser production, because cvBindsAndSigs is not + -- called on top-level declarations. + drop_bad_decls [] = return [] + drop_bad_decls (L l (SpliceD _ d) : ds) = do + addError l $ + hang (text "Declaration splices are allowed only" <+> + text "at the top level:") + 2 (ppr d) + drop_bad_decls ds + drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds ----------------------------------------------------------------------------- -- Group function bindings into equation groups @@ -512,6 +505,14 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1) getMonoBind bind binds = (bind, binds) +-- Group together adjacent FunBinds for every function. +getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] +getMonoBindAll [] = [] +getMonoBindAll (L l (ValD _ b) : ds) = + let (L l' b', ds') = getMonoBind (L l b) ds + in L l' (ValD noExtField b') : getMonoBindAll ds' +getMonoBindAll (d : ds) = d : getMonoBindAll ds + has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool has_args [] = panic "GHC.Parser.PostProcess.has_args" has_args (L _ (Match { m_pats = args }) : _) = not (null args) @@ -1035,21 +1036,7 @@ checkContext (L l orig_t) else (anns ++ mkParensApiAnn lp1) -- no need for anns, returning original - check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t]) - - msg = text "data constructor context" - --- | Check recursively if there are any 'HsDocTy's in the given type. --- This only works on a subset of types produced by 'btype_no_ops' -checkNoDocs :: SDoc -> LHsType GhcPs -> P () -checkNoDocs msg ty = go ty - where - go (L _ (HsAppKindTy _ ty ki)) = go ty *> go ki - go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 - go (L l (HsDocTy _ t ds)) = addError l $ hsep - [ text "Unexpected haddock", quotes (ppr ds) - , text "on", msg, quotes (ppr t) ] - go _ = pure () + check _anns _t = return ([],L l [L l orig_t]) checkImportDecl :: Maybe (Located Token) -> Maybe (Located Token) @@ -1338,7 +1325,6 @@ data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) | TyElKindApp SrcSpan (LHsType GhcPs) -- See Note [TyElKindApp SrcSpan interpretation] | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness) - | TyElDocPrev HsDocString {- Note [TyElKindApp SrcSpan interpretation] @@ -1360,7 +1346,6 @@ instance Outputable TyEl where ppr (TyElOpd ty) = ppr ty ppr (TyElKindApp _ ki) = text "@" <> ppr ki ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk - ppr (TyElDocPrev doc) = ppr doc -- | Extract a strictness/unpackedness annotation from the front of a reversed -- 'TyEl' list. @@ -1447,11 +1432,6 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs -- See Note [Impossible case in mergeOps clause [unpk]] panic "mergeOps.UNPACK: impossible position" - -- clause [doc]: - -- we do not expect to encounter any docs - go _ _ _ ((L l (TyElDocPrev _)):_) = - failOpDocPrev l - -- clause [opr]: -- when we encounter an operator, we must have accumulated -- something for its rhs, and there must be something left @@ -1571,13 +1551,6 @@ pLHsTypeArg (L l (TyElOpd a)) = Just (HsValArg (L l a)) pLHsTypeArg (L _ (TyElKindApp l a)) = Just (HsTypeArg l a) pLHsTypeArg _ = Nothing -pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl]) -pDocPrev = go Nothing - where - go mTrailingDoc ((L l (TyElDocPrev doc)):xs) = - go (mTrailingDoc `mplus` Just (L l doc)) xs - go mTrailingDoc xs = (mTrailingDoc, xs) - orErr :: Maybe a -> b -> Either b a orErr (Just a) _ = Right a orErr Nothing b = Left b @@ -1594,123 +1567,77 @@ mergeDataCon :: [Located TyEl] -> P ( Located RdrName -- constructor name , HsConDeclDetails GhcPs -- constructor field information - , Maybe LHsDocString -- docstring to go on the constructor ) mergeDataCon all_xs = do { (addAnns, a) <- eitherToP res ; addAnns ; return a } where - -- We start by splitting off the trailing documentation comment, - -- if any exists. - (mTrailingDoc, all_xs') = pDocPrev all_xs - - -- Determine whether the trailing documentation comment exists and is the - -- only docstring in this constructor declaration. - -- - -- When true, it means that it applies to the constructor itself: - -- data T = C - -- A - -- B -- ^ Comment on C (singleDoc == True) - -- - -- When false, it means that it applies to the last field: - -- data T = C -- ^ Comment on C - -- A -- ^ Comment on A - -- B -- ^ Comment on B (singleDoc == False) - singleDoc = isJust mTrailingDoc && - null [ () | (L _ (TyElDocPrev _)) <- all_xs' ] - -- The result of merging the list of reversed TyEl into a -- data constructor, along with [AddAnn]. - res = goFirst all_xs' - - -- Take the trailing docstring into account when interpreting - -- the docstring near the constructor. - -- - -- data T = C -- ^ docstring right after C - -- A - -- B -- ^ trailing docstring - -- - -- 'mkConDoc' must be applied to the docstring right after C, so that it - -- falls back to the trailing docstring when appropriate (see singleDoc). - mkConDoc mDoc | singleDoc = mDoc `mplus` mTrailingDoc - | otherwise = mDoc - - -- The docstring for the last field of a data constructor. - trailingFieldDoc | singleDoc = Nothing - | otherwise = mTrailingDoc + res = goFirst all_xs goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] = do { data_con <- tyConToDataCon l tc - ; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) } + ; return (pure (), (data_con, PrefixCon [])) } goFirst ((L l (TyElOpd (HsRecTy _ fields))):xs) - | (mConDoc, xs') <- pDocPrev xs - , [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs' + | [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs = do { data_con <- tyConToDataCon l' tc - ; let mDoc = mTrailingDoc `mplus` mConDoc - ; return (pure (), (data_con, RecCon (L l fields), mDoc)) } + ; return (pure (), (data_con, RecCon (L l fields))) } goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] = return ( pure () , ( L l (getRdrName (tupleDataCon Boxed (length ts))) - , PrefixCon (map hsLinear ts) - , mTrailingDoc ) ) + , PrefixCon (map hsLinear ts) ) ) goFirst ((L l (TyElOpd t)):xs) | (_, t', addAnns, xs') <- pBangTy (L l t) xs - = go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs' + = go addAnns [t'] xs' goFirst (L l (TyElKindApp _ _):_) = goInfix Monoid.<> Left (l, kindAppErr) goFirst xs - = go (pure ()) mTrailingDoc [] xs + = go (pure ()) [] xs - go addAnns mLastDoc ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] + go addAnns ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] = do { data_con <- tyConToDataCon l tc - ; return (addAnns, (data_con, PrefixCon (map hsLinear ts), mkConDoc mLastDoc)) } - go addAnns mLastDoc ts ((L l (TyElDocPrev doc)):xs) = - go addAnns (mLastDoc `mplus` Just (L l doc)) ts xs - go addAnns mLastDoc ts ((L l (TyElOpd t)):xs) + ; return (addAnns, (data_con, PrefixCon (map hsLinear ts))) } + go addAnns ts ((L l (TyElOpd t)):xs) | (_, t', addAnns', xs') <- pBangTy (L l t) xs - , t'' <- mkLHsDocTyMaybe t' mLastDoc - = go (addAnns >> addAnns') Nothing (t'':ts) xs' - go _ _ _ ((L _ (TyElOpr _)):_) = + = go (addAnns >> addAnns') (t':ts) xs' + go _ _ ((L _ (TyElOpr _)):_) = -- Encountered an operator: backtrack to the beginning and attempt -- to parse as an infix definition. goInfix - go _ _ _ (L l (TyElKindApp _ _):_) = goInfix Monoid.<> Left (l, kindAppErr) - go _ _ _ _ = Left malformedErr + go _ _ (L l (TyElKindApp _ _):_) = goInfix Monoid.<> Left (l, kindAppErr) + go _ _ _ = Left malformedErr where malformedErr = - ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs') + ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs) , text "Cannot parse data constructor" <+> text "in a data/newtype declaration:" $$ - nest 2 (hsep . reverse $ map ppr all_xs')) + nest 2 (hsep . reverse $ map ppr all_xs)) goInfix = - do { let xs0 = all_xs' - ; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr - ; let (mOpDoc, xs2) = pDocPrev xs1 - ; (op, xs3) <- case xs2 of + do { let xs0 = all_xs + ; (rhs, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr + ; (op, xs3) <- case xs1 of (L l (TyElOpr op)) : xs3 -> do { data_con <- tyConToDataCon l op ; return (data_con, xs3) } _ -> Left malformedErr - ; let (mLhsDoc, xs4) = pDocPrev xs3 - ; (lhs_t, lhs_addAnns, xs5) <- pInfixSide xs4 `orErr` malformedErr + ; (lhs, lhs_addAnns, xs5) <- pInfixSide xs3 `orErr` malformedErr ; unless (null xs5) (Left malformedErr) - ; let rhs = mkLHsDocTyMaybe rhs_t trailingFieldDoc - lhs = mkLHsDocTyMaybe lhs_t mLhsDoc - addAnns = lhs_addAnns >> rhs_addAnns - ; return (addAnns, (op, InfixCon (hsLinear lhs) (hsLinear rhs), mkConDoc mOpDoc)) } + ; let addAnns = lhs_addAnns >> rhs_addAnns + ; return (addAnns, (op, InfixCon (hsLinear lhs) (hsLinear rhs))) } where malformedErr = - ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs') + ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs) , text "Cannot parse an infix data constructor" <+> text "in a data/newtype declaration:" $$ - nest 2 (hsep . reverse $ map ppr all_xs')) + nest 2 (hsep . reverse $ map ppr all_xs)) kindAppErr = text "Unexpected kind application" <+> text "in a data/newtype declaration:" $$ - nest 2 (hsep . reverse $ map ppr all_xs') + nest 2 (hsep . reverse $ map ppr all_xs) --------------------------------------------------------------------------- -- | Check for monad comprehensions @@ -2902,11 +2829,6 @@ failOpFewArgs (L loc op) = where too_few = text "Operator applied to too few arguments:" <+> ppr op -failOpDocPrev :: SrcSpan -> P a -failOpDocPrev loc = addFatalError loc msg - where - msg = text "Unexpected documentation comment." - ----------------------------------------------------------------------------- -- Misc utils @@ -3140,14 +3062,6 @@ mkLHsOpTy x op y = let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y in L loc (mkHsOpTy x op y) -mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs -mkLHsDocTy t doc = - let loc = getLoc t `combineSrcSpans` getLoc doc - in L loc (HsDocTy noExtField t doc) - -mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs -mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t) - ----------------------------------------------------------------------------- -- Token symbols diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 409b0c120f..e109fada55 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -1,39 +1,1554 @@ -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingVia #-} -module GHC.Parser.PostProcess.Haddock where +{- | This module implements 'addHaddockToModule', which inserts Haddock + comments accumulated during parsing into the AST (#17544). -import GHC.Prelude +We process Haddock comments in two phases: + +1. Parse the program (via the Happy parser in `Parser.y`), generating + an AST, and (quite separately) a list of all the Haddock comments + found in the file. More precisely, the Haddock comments are + accumulated in the `hdk_comments` field of the `PState`, the parser + state (see Lexer.x): + + data PState = PState { ... + , hdk_comments :: [PsLocated HdkComment] } + + Each of these Haddock comments has a `PsSpan`, which gives the `BufPos` of + the beginning and end of the Haddock comment. + +2. Walk over the AST, attaching the Haddock comments to the correct + parts of the tree. This step is called `addHaddockToModule`, and is + implemented in this module. + + See Note [Adding Haddock comments to the syntax tree]. + +This approach codifies an important principle: + + The presence or absence of a Haddock comment should never change the parsing + of a program. + +Alternative approaches that did not work properly: + +1. Using 'RealSrcLoc' instead of 'BufPos'. This led to failures in presence + of {-# LANGUAGE CPP #-} and other sources of line pragmas. See documentation + on 'BufPos' (in GHC.Types.SrcLoc) for the details. + +2. In earlier versions of GHC, the Haddock comments were incorporated into the + Parser.y grammar. The parser constructed the AST and attached comments to it in + a single pass. See Note [Old solution: Haddock in the grammar] for the details. +-} +module GHC.Parser.PostProcess.Haddock (addHaddockToModule) where + +import GHC.Prelude hiding (mod) import GHC.Hs import GHC.Types.SrcLoc +import GHC.Driver.Session ( WarningFlag(..) ) +import GHC.Utils.Outputable hiding ( (<>) ) +import GHC.Data.Bag +import Data.Semigroup +import Data.Foldable +import Data.Traversable +import Data.Maybe import Control.Monad +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer +import Data.Functor.Identity +import Data.Coerce +import qualified Data.Monoid + +import GHC.Parser.Lexer +import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>)) + +{- Note [Adding Haddock comments to the syntax tree] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'addHaddock' traverses the AST in concrete syntax order, building a computation +(represented by HdkA) that reconstructs the AST but with Haddock comments +inserted in appropriate positions: + + addHaddock :: HasHaddock a => a -> HdkA a + +Consider this code example: + + f :: Int -- ^ comment on argument + -> Bool -- ^ comment on result + +In the AST, the "Int" part of this snippet is represented like this +(pseudo-code): + + L (BufSpan 6 8) (HsTyVar "Int") :: LHsType GhcPs + +And the comments are represented like this (pseudo-code): + + L (BufSpan 11 35) (HdkCommentPrev "comment on argument") + L (BufSpan 46 69) (HdkCommentPrev "comment on result") + +So when we are traversing the AST and 'addHaddock' is applied to HsTyVar "Int", +how does it know to associate it with "comment on argument" but not with +"comment on result"? + +The trick is to look in the space between syntactic elements. In the example above, +the location range in which we search for HdkCommentPrev is as follows: + + f :: Int████████████████████████ + ████Bool -- ^ comment on result + +We search for comments after HsTyVar "Int" and until the next syntactic +element, in this case HsTyVar "Bool". + +Ignoring the "->" allows us to accomodate alternative coding styles: + + f :: Int -> -- ^ comment on argument + Bool -- ^ comment on result + +Sometimes we also need to take indentation information into account. +Compare the following examples: + + class C a where + f :: a -> Int + -- ^ comment on f + + class C a where + f :: a -> Int + -- ^ comment on C + +Notice how "comment on f" and "comment on C" differ only by indentation level. + +Therefore, in order to know the location range in which the comments are applicable +to a syntactic elements, we need three nuggets of information: + 1. lower bound on the BufPos of a comment + 2. upper bound on the BufPos of a comment + 3. minimum indentation level of a comment + +This information is represented by the 'LocRange' type. + +In order to propagate this information, we have the 'HdkA' applicative. +'HdkA' is defined as follows: + + data HdkA a = HdkA (Maybe BufSpan) (HdkM a) + +The first field contains a 'BufSpan', which represents the location +span taken by a syntactic element: + + addHaddock (L bufSpan ...) = HdkA (Just bufSpan) ... + +The second field, 'HdkM', is a stateful computation that looks up Haddock +comments in the specified location range: + + HdkM a ≈ + LocRange -- The allowed location range + -> [PsLocated HdkComment] -- Unallocated comments + -> (a, -- AST with comments inserted into it + [PsLocated HdkComment]) -- Leftover comments + +The 'Applicative' instance for 'HdkA' is defined in such a way that the +location range of every computation is defined by its neighbours: + + addHaddock aaa <*> addHaddock bbb <*> addHaddock ccc + +Here, the 'LocRange' passed to the 'HdkM' computation of addHaddock bbb +is determined by the BufSpan recorded in addHaddock aaa and addHaddock ccc. + +This is why it's important to traverse the AST in the order of the concrete +syntax. In the example above we assume that aaa, bbb, ccc are ordered by location: + + * getBufSpan (getLoc aaa) < getBufSpan (getLoc bbb) + * getBufSpan (getLoc bbb) < getBufSpan (getLoc ccc) + +Violation of this assumption would lead to bugs, and care must be taken to +traverse the AST correctly. For example, when dealing with class declarations, +we have to use 'flattenBindsAndSigs' to traverse it in the correct order. +-} + +-- | Add Haddock documentation accumulated in the parser state +-- to a parsed HsModule. +-- +-- Reports badly positioned comments when -Winvalid-haddock is enabled. +addHaddockToModule :: Located HsModule -> P (Located HsModule) +addHaddockToModule lmod = do + pState <- getPState + let all_comments = toList (hdk_comments pState) + initial_hdk_st = HdkSt all_comments [] + (lmod', final_hdk_st) = runHdkA (addHaddock lmod) initial_hdk_st + hdk_warnings = collectHdkWarnings final_hdk_st + -- lmod': module with Haddock comments inserted into the AST + -- hdk_warnings: warnings accumulated during AST/comment processing + mapM_ reportHdkWarning hdk_warnings + return lmod' + +reportHdkWarning :: HdkWarn -> P () +reportHdkWarning (HdkWarnInvalidComment (L l _)) = + addWarning Opt_WarnInvalidHaddock (mkSrcSpanPs l) $ + text "A Haddock comment cannot appear in this position and will be ignored." +reportHdkWarning (HdkWarnExtraComment (L l _)) = + addWarning Opt_WarnInvalidHaddock l $ + text "Multiple Haddock comments for a single entity are not allowed." $$ + text "The extraneous comment will be ignored." + +collectHdkWarnings :: HdkSt -> [HdkWarn] +collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } = + map HdkWarnInvalidComment hdk_st_pending -- leftover Haddock comments not inserted into the AST + ++ hdk_st_warnings + +{- ********************************************************************* +* * +* addHaddock: a family of functions that processes the AST * +* in concrete syntax order, adding documentation comments to it * +* * +********************************************************************* -} + +-- HasHaddock is a convenience class for overloading the addHaddock operation. +-- Alternatively, we could define a family of monomorphic functions: +-- +-- addHaddockSomeTypeX :: SomeTypeX -> HdkA SomeTypeX +-- addHaddockAnotherTypeY :: AnotherTypeY -> HdkA AnotherTypeY +-- addHaddockOneMoreTypeZ :: OneMoreTypeZ -> HdkA OneMoreTypeZ +-- +-- But having a single name for all of them is just easier to read, and makes it clear +-- that they all are of the form t -> HdkA t for some t. +-- +-- If you need to handle a more complicated scenario that doesn't fit this +-- pattern, it's always possible to define separate functions outside of this +-- class, as is done in case of e.g. addHaddockConDeclField. +-- +-- See Note [Adding Haddock comments to the syntax tree]. +class HasHaddock a where + addHaddock :: a -> HdkA a + +instance HasHaddock a => HasHaddock [a] where + addHaddock = traverse addHaddock + +-- -- | Module header comment +-- module M ( +-- -- * Export list comment +-- Item1, +-- Item2, +-- -- * Export list comment +-- item3, +-- item4 +-- ) where +-- +instance HasHaddock (Located HsModule) where + addHaddock (L l_mod mod) = do + -- Step 1, get the module header documentation comment: + -- + -- -- | Module header comment + -- module M where + -- + -- Only do this when the module header exists. + headerDocs <- + for @Maybe (hsmodName mod) $ \(L l_name _) -> + extendHdkA l_name $ liftHdkA $ do + -- todo: register keyword location of 'module', see Note [Register keyword location] + docs <- + inLocRange (locRangeTo (getBufPos (srcSpanStart l_name))) $ + takeHdkComments mkDocNext + selectDocString docs + + -- Step 2, process documentation comments in the export list: + -- + -- module M ( + -- -- * Export list comment + -- Item1, + -- Item2, + -- -- * Export list comment + -- item3, + -- item4 + -- ) where + -- + -- Only do this when the export list exists. + hsmodExports' <- traverse @Maybe addHaddock (hsmodExports mod) + + -- Step 3, register the import section to reject invalid comments: + -- + -- import Data.Maybe + -- -- | rejected comment (cannot appear here) + -- import Data.Bool + -- + traverse_ registerHdkA (hsmodImports mod) + + -- Step 4, process declarations: + -- + -- module M where + -- -- | Comment on D + -- data D = MkD -- ^ Comment on MkD + -- data C = MkC -- ^ Comment on MkC + -- -- ^ Comment on C + -- + let layout_info = hsmodLayout mod + hsmodDecls' <- addHaddockInterleaveItems layout_info (mkDocHsDecl layout_info) (hsmodDecls mod) + + pure $ L l_mod $ + mod { hsmodExports = hsmodExports' + , hsmodDecls = hsmodDecls' + , hsmodHaddockModHeader = join @Maybe headerDocs } + +-- Only for module exports, not module imports. +-- +-- module M (a, b, c) where -- use on this [LIE GhcPs] +-- import I (a, b, c) -- do not use here! +-- +-- Imports cannot have documentation comments anyway. +instance HasHaddock (Located [LIE GhcPs]) where + addHaddock (L l_exports exports) = + extendHdkA l_exports $ do + exports' <- addHaddockInterleaveItems NoLayoutInfo mkDocIE exports + registerLocHdkA (srcLocSpan (srcSpanEnd l_exports)) -- Do not consume comments after the closing parenthesis + pure $ L l_exports exports' + +-- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'. +instance HasHaddock (LIE GhcPs) where + addHaddock a = a <$ registerHdkA a + +{- Add Haddock items to a list of non-Haddock items. +Used to process export lists (with mkDocIE) and declarations (with mkDocHsDecl). + +For example: + + module M where + -- | Comment on D + data D = MkD -- ^ Comment on MkD + data C = MkC -- ^ Comment on MkC + -- ^ Comment on C + +In this case, we should produce four HsDecl items (pseudo-code): + + 1. DocD (DocCommentNext "Comment on D") + 2. TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... (Just "Comment on MkD")]) + 3. TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... (Just "Comment on MkC")]) + 4. DocD (DocCommentPrev "Comment on C") + +The inputs to addHaddockInterleaveItems are: + + * layout_info :: LayoutInfo + + In the example above, note that the indentation level inside the module is + 2 spaces. It would be represented as layout_info = VirtualBraces 2. + + It is used to delimit the search space for comments when processing + declarations. Here, we restrict indentation levels to >=(2+1), so that when + we look up comment on MkC, we get "Comment on MkC" but not "Comment on C". + + * get_doc_item :: PsLocated HdkComment -> Maybe a + + This is the function used to look up documentation comments. + In the above example, get_doc_item = mkDocHsDecl layout_info, + and it will produce the following parts of the output: + + DocD (DocCommentNext "Comment on D") + DocD (DocCommentPrev "Comment on C") + + * The list of items. These are the declarations that will be annotated with + documentation comments. + + Before processing: + TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... Nothing]) + TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... Nothing]) + + After processing: + TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... (Just "Comment on MkD")]) + TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... (Just "Comment on MkC")]) +-} +addHaddockInterleaveItems + :: forall a. + HasHaddock a + => LayoutInfo + -> (PsLocated HdkComment -> Maybe a) -- Get a documentation item + -> [a] -- Unprocessed (non-documentation) items + -> HdkA [a] -- Documentation items & processed non-documentation items +addHaddockInterleaveItems layout_info get_doc_item = go + where + go :: [a] -> HdkA [a] + go [] = liftHdkA (takeHdkComments get_doc_item) + go (item : items) = do + docItems <- liftHdkA (takeHdkComments get_doc_item) + item' <- with_layout_info (addHaddock item) + other_items <- go items + pure $ docItems ++ item':other_items + + with_layout_info :: HdkA a -> HdkA a + with_layout_info = case layout_info of + NoLayoutInfo -> id + ExplicitBraces -> id + VirtualBraces n -> + let loc_range = mempty { loc_range_col = ColumnFrom (n+1) } + in hoistHdkA (inLocRange loc_range) + +instance HasHaddock (LHsDecl GhcPs) where + addHaddock ldecl = + extendHdkA (getLoc ldecl) $ + traverse @Located addHaddock ldecl + +-- Process documentation comments *inside* a declaration, for example: +-- +-- data T = MkT -- ^ Comment on MkT (inside DataDecl) +-- f, g +-- :: Int -- ^ Comment on Int (inside TypeSig) +-- -> Bool -- ^ Comment on Bool (inside TypeSig) +-- +-- Comments that relate to the entire declaration are processed elsewhere: +-- +-- -- | Comment on T (not processed in this instance) +-- data T = MkT +-- +-- -- | Comment on f, g (not processed in this instance) +-- f, g :: Int -> Bool +-- f = ... +-- g = ... +-- +-- Such comments are inserted into the syntax tree as DocD declarations +-- by addHaddockInterleaveItems, and then associated with other declarations +-- in GHC.HsToCore.Docs (see DeclDocMap). +-- +-- In this instance, we only process comments that relate to parts of the +-- declaration, not to the declaration itself. +instance HasHaddock (HsDecl GhcPs) where + + -- Type signatures: + -- + -- f, g + -- :: Int -- ^ Comment on Int + -- -> Bool -- ^ Comment on Bool + -- + addHaddock (SigD _ (TypeSig _ names t)) = do + traverse_ registerHdkA names + t' <- addHaddock t + pure (SigD noExtField (TypeSig noExtField names t')) + + -- Pattern synonym type signatures: + -- + -- pattern MyPat + -- :: Bool -- ^ Comment on Bool + -- -> Maybe Bool -- ^ Comment on Maybe Bool + -- + addHaddock (SigD _ (PatSynSig _ names t)) = do + traverse_ registerHdkA names + t' <- addHaddock t + pure (SigD noExtField (PatSynSig noExtField names t')) + + -- Class method signatures and default signatures: + -- + -- class C x where + -- method_of_c + -- :: Maybe x -- ^ Comment on Maybe x + -- -> IO () -- ^ Comment on IO () + -- default method_of_c + -- :: Eq x + -- => Maybe x -- ^ Comment on Maybe x + -- -> IO () -- ^ Comment on IO () + -- + addHaddock (SigD _ (ClassOpSig _ is_dflt names t)) = do + traverse_ registerHdkA names + t' <- addHaddock t + pure (SigD noExtField (ClassOpSig noExtField is_dflt names t')) + + -- Data/newtype declarations: + -- + -- data T = MkT -- ^ Comment on MkT + -- A -- ^ Comment on A + -- B -- ^ Comment on B + -- + -- data G where + -- -- | Comment on MkG + -- MkG :: A -- ^ Comment on A + -- -> B -- ^ Comment on B + -- -> G + -- + -- newtype N = MkN { getN :: Natural } -- ^ Comment on N + -- deriving newtype (Eq {- ^ Comment on Eq N -}) + -- deriving newtype (Ord {- ^ Comment on Ord N -}) + -- + addHaddock (TyClD _ decl) + | DataDecl { tcdLName, tcdTyVars, tcdFixity, tcdDataDefn = defn } <- decl + = do + registerHdkA tcdLName + defn' <- addHaddock defn + pure $ + TyClD noExtField (DataDecl { + tcdDExt = noExtField, + tcdLName, tcdTyVars, tcdFixity, + tcdDataDefn = defn' }) + + -- Class declarations: + -- + -- class C a where + -- -- | Comment on the first method + -- first_method :: a -> Bool + -- second_method :: a -> String + -- -- ^ Comment on the second method + -- + addHaddock (TyClD _ decl) + | ClassDecl { tcdCExt = tcdLayout, + tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs, + tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl + = do + registerHdkA tcdLName + -- todo: register keyword location of 'where', see Note [Register keyword location] + where_cls' <- + addHaddockInterleaveItems tcdLayout (mkDocHsDecl tcdLayout) $ + flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], []) + pure $ + let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs where_cls' + decl' = ClassDecl { tcdCExt = tcdLayout + , tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs + , tcdSigs = tcdSigs' + , tcdMeths = tcdMeths' + , tcdATs = tcdATs' + , tcdATDefs = tcdATDefs' + , tcdDocs } + in TyClD noExtField decl' + + -- Data family instances: + -- + -- data instance D Bool where ... (same as data/newtype declarations) + -- data instance D Bool = ... (same as data/newtype declarations) + -- + addHaddock (InstD _ decl) + | DataFamInstD { dfid_inst } <- decl + , DataFamInstDecl { dfid_eqn } <- dfid_inst + = do + dfid_eqn' <- case dfid_eqn of + HsIB _ (FamEqn { feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs }) + -> do + registerHdkA feqn_tycon + feqn_rhs' <- addHaddock feqn_rhs + pure $ + HsIB noExtField (FamEqn { + feqn_ext = noExtField, + feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, + feqn_rhs = feqn_rhs' }) + pure $ InstD noExtField (DataFamInstD { + dfid_ext = noExtField, + dfid_inst = DataFamInstDecl { dfid_eqn = dfid_eqn' } }) + + -- Type synonyms: + -- + -- type T = Int -- ^ Comment on Int + -- + addHaddock (TyClD _ decl) + | SynDecl { tcdLName, tcdTyVars, tcdFixity, tcdRhs } <- decl + = do + registerHdkA tcdLName + -- todo: register keyword location of '=', see Note [Register keyword location] + tcdRhs' <- addHaddock tcdRhs + pure $ + TyClD noExtField (SynDecl { + tcdSExt = noExtField, + tcdLName, tcdTyVars, tcdFixity, + tcdRhs = tcdRhs' }) + + -- Foreign imports: + -- + -- foreign import ccall unsafe + -- o :: Float -- ^ The input float + -- -> IO Float -- ^ The output float + -- + addHaddock (ForD _ decl) = do + registerHdkA (fd_name decl) + fd_sig_ty' <- addHaddock (fd_sig_ty decl) + pure $ ForD noExtField (decl{ fd_sig_ty = fd_sig_ty' }) + + -- Other declarations + addHaddock d = pure d + +-- The right-hand side of a data/newtype declaration or data family instance. +instance HasHaddock (HsDataDefn GhcPs) where + addHaddock defn@HsDataDefn{} = do + + -- Register the kind signature: + -- data D :: Type -> Type where ... + -- data instance D Bool :: Type where ... + traverse_ @Maybe registerHdkA (dd_kindSig defn) + -- todo: register keyword location of '=' or 'where', see Note [Register keyword location] + + -- Process the data constructors: + -- + -- data T + -- = MkT1 Int Bool -- ^ Comment on MkT1 + -- | MkT2 Char Int -- ^ Comment on MkT2 + -- + dd_cons' <- addHaddock (dd_cons defn) + + -- Process the deriving clauses: + -- + -- newtype N = MkN Natural + -- deriving (Eq {- ^ Comment on Eq N -}) + -- deriving (Ord {- ^ Comment on Ord N -}) + -- + dd_derivs' <- addHaddock (dd_derivs defn) + + pure $ defn { dd_cons = dd_cons', + dd_derivs = dd_derivs' } + +-- Process the deriving clauses of a data/newtype declaration. +-- Not used for standalone deriving. +instance HasHaddock (HsDeriving GhcPs) where + addHaddock lderivs = + extendHdkA (getLoc lderivs) $ + traverse @Located addHaddock lderivs + +-- Process a single deriving clause of a data/newtype declaration: +-- +-- newtype N = MkN Natural +-- deriving newtype (Eq {- ^ Comment on Eq N -}) +-- deriving (Ord {- ^ Comment on Ord N -}) via Down N +-- +-- Not used for standalone deriving. +instance HasHaddock (LHsDerivingClause GhcPs) where + addHaddock lderiv = + extendHdkA (getLoc lderiv) $ + for @Located lderiv $ \deriv -> + case deriv of + HsDerivingClause { deriv_clause_strategy, deriv_clause_tys } -> do + let + -- 'stock', 'anyclass', and 'newtype' strategies come + -- before the clause types. + -- + -- 'via' comes after. + -- + -- See tests/.../T11768.hs + (register_strategy_before, register_strategy_after) = + case deriv_clause_strategy of + Nothing -> (pure (), pure ()) + Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA l) + Just (L l _) -> (registerLocHdkA l, pure ()) + register_strategy_before + deriv_clause_tys' <- + extendHdkA (getLoc deriv_clause_tys) $ + traverse @Located addHaddock deriv_clause_tys + register_strategy_after + pure HsDerivingClause + { deriv_clause_ext = noExtField, + deriv_clause_strategy, + deriv_clause_tys = deriv_clause_tys' } + +-- Process a single data constructor declaration, which may come in one of the +-- following forms: +-- +-- 1. H98-syntax PrefixCon: +-- data T = +-- MkT -- ^ Comment on MkT +-- Int -- ^ Comment on Int +-- Bool -- ^ Comment on Bool +-- +-- 2. H98-syntax InfixCon: +-- data T = +-- Int -- ^ Comment on Int +-- :+ -- ^ Comment on (:+) +-- Bool -- ^ Comment on Bool +-- +-- 3. H98-syntax RecCon: +-- data T = +-- MkT { int_field :: Int, -- ^ Comment on int_field +-- bool_field :: Bool } -- ^ Comment on bool_field +-- +-- 4. GADT-syntax PrefixCon: +-- data T where +-- -- | Comment on MkT +-- MkT :: Int -- ^ Comment on Int +-- -> Bool -- ^ Comment on Bool +-- -> T +-- +-- 5. GADT-syntax RecCon: +-- data T where +-- -- | Comment on MkT +-- MkT :: { int_field :: Int, -- ^ Comment on int_field +-- bool_field :: Bool } -- ^ Comment on bool_field +-- -> T +-- +instance HasHaddock (LConDecl GhcPs) where + addHaddock (L l_con_decl con_decl) = + extendHdkA l_con_decl $ + case con_decl of + ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_args, con_res_ty } -> do + -- discardHasInnerDocs is ok because we don't need this info for GADTs. + con_doc' <- discardHasInnerDocs $ getConDoc (getLoc (head con_names)) + con_args' <- + case con_args of + PrefixCon ts -> PrefixCon <$> addHaddock ts + RecCon (L l_rec flds) -> do + -- discardHasInnerDocs is ok because we don't need this info for GADTs. + flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds + pure $ RecCon (L l_rec flds') + InfixCon _ _ -> panic "ConDeclGADT InfixCon" + con_res_ty' <- addHaddock con_res_ty + pure $ L l_con_decl $ + ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, + con_doc = con_doc', + con_args = con_args', + con_res_ty = con_res_ty' } + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } -> + addConTrailingDoc (srcSpanEnd l_con_decl) $ + case con_args of + PrefixCon ts -> do + con_doc' <- getConDoc (getLoc con_name) + 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_args = PrefixCon ts' } + InfixCon t1 t2 -> do + t1' <- addHaddockConDeclFieldTy t1 + con_doc' <- getConDoc (getLoc con_name) + 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_args = InfixCon t1' t2' } + RecCon (L l_rec flds) -> do + con_doc' <- getConDoc (getLoc 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_args = RecCon (L l_rec flds') } + XConDecl (ConDeclGADTPrefixPs { con_gp_names, con_gp_ty }) -> do + -- discardHasInnerDocs is ok because we don't need this info for GADTs. + con_gp_doc' <- discardHasInnerDocs $ getConDoc (getLoc (head con_gp_names)) + con_gp_ty' <- addHaddock con_gp_ty + pure $ L l_con_decl $ + XConDecl (ConDeclGADTPrefixPs + { con_gp_names, + con_gp_ty = con_gp_ty', + con_gp_doc = con_gp_doc' }) + +-- Keep track of documentation comments on the data constructor or any of its +-- fields. +-- +-- See Note [Trailing comment on constructor declaration] +type ConHdkA = WriterT HasInnerDocs HdkA + +-- Does the data constructor declaration have any inner (non-trailing) +-- documentation comments? +-- +-- Example when HasInnerDocs is True: +-- +-- data X = +-- MkX -- ^ inner comment +-- Field1 -- ^ inner comment +-- Field2 -- ^ inner comment +-- Field3 -- ^ trailing comment +-- +-- Example when HasInnerDocs is False: +-- +-- data Y = MkY Field1 Field2 Field3 -- ^ trailing comment +-- +-- See Note [Trailing comment on constructor declaration] +newtype HasInnerDocs = HasInnerDocs Bool + deriving (Semigroup, Monoid) via Data.Monoid.Any + +-- Run ConHdkA by discarding the HasInnerDocs info when we have no use for it. +-- +-- We only do this when processing data declarations that use GADT syntax, +-- because only the H98 syntax declarations have special treatment for the +-- trailing documentation comment. +-- +-- See Note [Trailing comment on constructor declaration] +discardHasInnerDocs :: ConHdkA a -> HdkA a +discardHasInnerDocs = fmap fst . runWriterT + +-- Get the documentation comment associated with the data constructor in a +-- data/newtype declaration. +getConDoc + :: SrcSpan -- Location of the data constructor + -> ConHdkA (Maybe LHsDocString) +getConDoc l = + WriterT $ extendHdkA l $ liftHdkA $ do + mDoc <- getPrevNextDoc l + return (mDoc, HasInnerDocs (isJust mDoc)) + +-- Add documentation comment to a data constructor field. +-- Used for PrefixCon and InfixCon. +addHaddockConDeclFieldTy + :: HsScaled GhcPs (LHsType GhcPs) + -> ConHdkA (HsScaled GhcPs (LHsType GhcPs)) +addHaddockConDeclFieldTy (HsScaled mult (L l t)) = + WriterT $ extendHdkA l $ liftHdkA $ do + mDoc <- getPrevNextDoc l + return (HsScaled mult (mkLHsDocTy (L l t) mDoc), + HasInnerDocs (isJust mDoc)) + +-- Add documentation comment to a data constructor field. +-- Used for RecCon. +addHaddockConDeclField + :: LConDeclField GhcPs + -> ConHdkA (LConDeclField GhcPs) +addHaddockConDeclField (L l_fld fld) = + WriterT $ extendHdkA l_fld $ liftHdkA $ do + cd_fld_doc <- getPrevNextDoc l_fld + return (L l_fld (fld { cd_fld_doc }), + HasInnerDocs (isJust cd_fld_doc)) + +-- 1. Process a H98-syntax data constructor declaration in a context with no +-- access to the trailing documentation comment (by running the provided +-- ConHdkA computation). +-- +-- 2. Then grab the trailing comment (if it exists) and attach it where +-- appropriate: either to the data constructor itself or to its last field, +-- depending on HasInnerDocs. +-- +-- See Note [Trailing comment on constructor declaration] +addConTrailingDoc + :: SrcLoc -- The end of a data constructor declaration. + -- Any docprev comment past this point is considered trailing. + -> ConHdkA (LConDecl GhcPs) + -> HdkA (LConDecl GhcPs) +addConTrailingDoc l_sep = + hoistHdkA add_trailing_doc . runWriterT + where + add_trailing_doc + :: HdkM (LConDecl GhcPs, HasInnerDocs) + -> HdkM (LConDecl GhcPs) + add_trailing_doc m = do + (L l con_decl, HasInnerDocs has_inner_docs) <- + inLocRange (locRangeTo (getBufPos l_sep)) m + -- inLocRange delimits the context so that the inner computation + -- will not consume the trailing documentation comment. + case con_decl of + ConDeclH98{} -> do + trailingDocs <- + inLocRange (locRangeFrom (getBufPos l_sep)) $ + takeHdkComments mkDocPrev + if null trailingDocs + then return (L l con_decl) + else do + if has_inner_docs then do + let mk_doc_ty :: HsScaled GhcPs (LHsType GhcPs) + -> HdkM (HsScaled GhcPs (LHsType GhcPs)) + mk_doc_ty x@(HsScaled _ (L _ HsDocTy{})) = + -- Happens in the following case: + -- + -- data T = + -- MkT + -- -- | Comment on SomeField + -- SomeField + -- -- ^ Another comment on SomeField? (rejected) + -- + -- See tests/.../haddockExtraDocs.hs + x <$ reportExtraDocs trailingDocs + mk_doc_ty (HsScaled mult (L l' t)) = do + doc <- selectDocString trailingDocs + return $ HsScaled mult (mkLHsDocTy (L l' t) doc) + let mk_doc_fld :: LConDeclField GhcPs + -> HdkM (LConDeclField GhcPs) + mk_doc_fld x@(L _ (ConDeclField { cd_fld_doc = Just _ })) = + -- Happens in the following case: + -- + -- data T = + -- MkT { + -- -- | Comment on SomeField + -- someField :: SomeField + -- } -- ^ Another comment on SomeField? (rejected) + -- + -- See tests/.../haddockExtraDocs.hs + x <$ reportExtraDocs trailingDocs + mk_doc_fld (L l' con_fld) = do + doc <- selectDocString trailingDocs + return $ L l' (con_fld { cd_fld_doc = doc }) + con_args' <- case con_args con_decl of + x@(PrefixCon []) -> x <$ reportExtraDocs trailingDocs + x@(RecCon (L _ [])) -> x <$ reportExtraDocs trailingDocs + PrefixCon ts -> PrefixCon <$> mapLastM mk_doc_ty ts + InfixCon t1 t2 -> InfixCon t1 <$> mk_doc_ty t2 + RecCon (L l_rec flds) -> do + flds' <- mapLastM mk_doc_fld flds + 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) + return $ L l (con_decl{ con_doc = con_doc' }) + _ -> panic "addConTrailingDoc: non-H98 ConDecl" + +{- Note [Trailing comment on constructor declaration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The trailing comment after a constructor declaration is associated with the +constructor itself when there are no other comments inside the declaration: + + data T = MkT A B -- ^ Comment on MkT + data T = MkT { x :: A } -- ^ Comment on MkT + +When there are other comments, the trailing comment applies to the last field: + + data T = MkT -- ^ Comment on MkT + A -- ^ Comment on A + B -- ^ Comment on B + + data T = + MkT { a :: A -- ^ Comment on a + , b :: B -- ^ Comment on b + , c :: C } -- ^ Comment on c + +This makes the trailing comment context-sensitive. Example: + data T = + -- | comment 1 + MkT Int Bool -- ^ comment 2 + + Here, "comment 2" applies to the Bool field. + But if we removed "comment 1", then "comment 2" would be apply to the data + constructor rather than its field. + +All of this applies to H98-style data declarations only. +GADTSyntax data constructors don't have any special treatment for the trailing comment. + +We implement this in two steps: + + 1. Process the data constructor declaration in a delimited context where the + trailing documentation comment is not visible. Delimiting the context is done + in addConTrailingDoc. + + When processing the declaration, track whether the constructor or any of + its fields have a documentation comment associated with them. + This is done using WriterT HasInnerDocs, see ConHdkA. + + 2. Depending on whether HasInnerDocs is True or False, attach the + trailing documentation comment to the data constructor itself + or to its last field. +-} + +instance HasHaddock a => HasHaddock (HsScaled GhcPs a) where + addHaddock (HsScaled mult a) = HsScaled mult <$> addHaddock a + +instance HasHaddock (LHsSigWcType GhcPs) where + addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t + +instance HasHaddock (LHsSigType GhcPs) where + addHaddock (HsIB _ t) = HsIB noExtField <$> addHaddock t + +-- Process a type, adding documentation comments to function arguments +-- and the result. Many formatting styles are supported. +-- +-- my_function :: +-- forall a. +-- Eq a => +-- Maybe a -> -- ^ Comment on Maybe a (function argument) +-- Bool -> -- ^ Comment on Bool (function argument) +-- String -- ^ Comment on String (the result) +-- +-- my_function +-- :: forall a. Eq a +-- => Maybe a -- ^ Comment on Maybe a (function argument) +-- -> Bool -- ^ Comment on Bool (function argument) +-- -> String -- ^ Comment on String (the result) +-- +-- my_function :: +-- forall a. Eq a => +-- -- | Comment on Maybe a (function argument) +-- Maybe a -> +-- -- | Comment on Bool (function argument) +-- Bool -> +-- -- | Comment on String (the result) +-- String +-- +-- This is achieved by simply ignoring (not registering the location of) the +-- function arrow (->). +instance HasHaddock (LHsType GhcPs) where + addHaddock (L l t) = + extendHdkA l $ + case t of + + -- forall a b c. t + HsForAllTy _ tele body -> do + registerLocHdkA (getForAllTeleLoc tele) + body' <- addHaddock body + pure $ L l (HsForAllTy noExtField tele body') + + -- (Eq a, Num a) => t + HsQualTy _ lhs rhs -> do + registerHdkA lhs + rhs' <- addHaddock rhs + pure $ L l (HsQualTy noExtField lhs rhs') + + -- arg -> res + HsFunTy _ mult lhs rhs -> do + lhs' <- addHaddock lhs + rhs' <- addHaddock rhs + pure $ L l (HsFunTy noExtField mult lhs' rhs') + + -- other types + _ -> liftHdkA $ do + mDoc <- getPrevNextDoc l + return (mkLHsDocTy (L l t) mDoc) + +{- ********************************************************************* +* * +* HdkA: a layer over HdkM that propagates location information * +* * +********************************************************************* -} + +-- See Note [Adding Haddock comments to the syntax tree]. +-- +-- 'HdkA' provides a way to propagate location information from surrounding +-- computations: +-- +-- left_neighbour <*> HdkA inner_span inner_m <*> right_neighbour +-- +-- Here, the following holds: +-- +-- * the 'left_neighbour' will only see Haddock comments until 'bufSpanStart' of 'inner_span' +-- * the 'right_neighbour' will only see Haddock comments after 'bufSpanEnd' of 'inner_span' +-- * the 'inner_m' will only see Haddock comments between its 'left_neighbour' and its 'right_neighbour' +-- +-- In other words, every computation: +-- +-- * delimits the surrounding computations +-- * is delimited by the surrounding computations +-- +-- Therefore, a 'HdkA' computation must be always considered in the context in +-- which it is used. +data HdkA a = + HdkA + !(Maybe BufSpan) -- Just b <=> BufSpan occupied by the processed AST element. + -- The surrounding computations will not look inside. + -- + -- Nothing <=> No BufSpan (e.g. when the HdkA is constructed by 'pure' or 'liftHdkA'). + -- The surrounding computations are not delimited. + + !(HdkM a) -- The stateful computation that looks up Haddock comments and + -- adds them to the resulting AST node. + + deriving (Functor) + +instance Applicative HdkA where + HdkA l1 m1 <*> HdkA l2 m2 = + HdkA + (l1 <> l2) -- The combined BufSpan that covers both subcomputations. + -- + -- The Semigroup instance for Maybe quite conveniently does the right thing: + -- Nothing <> b = b + -- a <> Nothing = a + -- Just a <> Just b = Just (a <> b) + + (delim1 m1 <*> delim2 m2) -- Stateful computations are run in left-to-right order, + -- without any smart reordering strategy. So users of this + -- operation must take care to traverse the AST + -- in concrete syntax order. + -- See Note [Smart reordering in HdkA (or lack of thereof)] + -- + -- Each computation is delimited ("sandboxed") + -- in a way that it doesn't see any Haddock + -- comments past the neighbouring AST node. + -- These delim1/delim2 are key to how HdkA operates. + where + -- Delimit the LHS by the location information from the RHS + delim1 = inLocRange (locRangeTo (fmap @Maybe bufSpanStart l2)) + -- Delimit the RHS by the location information from the LHS + delim2 = inLocRange (locRangeFrom (fmap @Maybe bufSpanEnd l1)) + + pure a = + -- Return a value without performing any stateful computation, and without + -- any delimiting effect on the surrounding computations. + liftHdkA (pure a) + +{- Note [Smart reordering in HdkA (or lack of thereof)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When traversing the AST, the user must take care to traverse it in concrete +syntax order. + +For example, when processing HsFunTy, it's important to get it right and write +it like so: + + HsFunTy _ mult lhs rhs -> do + lhs' <- addHaddock lhs + rhs' <- addHaddock rhs + pure $ L l (HsFunTy noExtField mult lhs' rhs') + +Rather than like so: + + HsFunTy _ mult lhs rhs -> do + rhs' <- addHaddock rhs -- bad! wrong order + lhs' <- addHaddock lhs -- bad! wrong order + pure $ L l (HsFunTy noExtField mult lhs' rhs') + +This is somewhat bug-prone, so we could try to fix this with some Applicative +magic. When we define (<*>) for HdkA, why not reorder the computations as +necessary? In pseudo-code: + + a1 <*> a2 | a1 `before` a2 = ... normal processing ... + | otherwise = a1 <**> a2 + +While this trick could work for any two *adjacent* AST elements out of order +(as in HsFunTy example above), it would fail in more elaborate scenarios (e.g. +processing a list of declarations out of order). + +If it's not obvious why this trick doesn't work, ponder this: it's a bit like trying to get +a sorted list by defining a 'smart' concatenation operator in the following manner: + + a ?++ b | a <= b = a ++ b + | otherwise = b ++ a + +At first glance it seems to work: + + ghci> [1] ?++ [2] ?++ [3] + [1,2,3] + + ghci> [2] ?++ [1] ?++ [3] + [1,2,3] -- wow, sorted! + +But it actually doesn't: + + ghci> [3] ?++ [1] ?++ [2] + [1,3,2] -- not sorted... +-} + +-- Run a HdkA computation in an unrestricted LocRange. This is only used at the +-- top level to run the final computation for the entire module. +runHdkA :: HdkA a -> HdkSt -> (a, HdkSt) +runHdkA (HdkA _ m) = unHdkM m mempty + +-- Let the neighbours know about an item at this location. +-- +-- Consider this example: +-- +-- class -- | peculiarly placed comment +-- MyClass a where +-- my_method :: a -> a +-- +-- How do we know to reject the "peculiarly placed comment" instead of +-- associating it with my_method? Its indentation level matches. +-- +-- But clearly, there's "MyClass a where" separating the comment and my_method. +-- To take it into account, we must register its location using registerLocHdkA +-- or registerHdkA. +-- +-- See Note [Register keyword location]. +-- See Note [Adding Haddock comments to the syntax tree]. +registerLocHdkA :: SrcSpan -> HdkA () +registerLocHdkA l = HdkA (getBufSpan l) (pure ()) + +-- Let the neighbours know about an item at this location. +-- A small wrapper over registerLocHdkA. +-- +-- See Note [Adding Haddock comments to the syntax tree]. +registerHdkA :: Located a -> HdkA () +registerHdkA a = registerLocHdkA (getLoc a) + +-- Modify the action of a HdkA computation. +hoistHdkA :: (HdkM a -> HdkM b) -> HdkA a -> HdkA b +hoistHdkA f (HdkA l m) = HdkA l (f m) + +-- Lift a HdkM computation to HdkA. +liftHdkA :: HdkM a -> HdkA a +liftHdkA = HdkA mempty + +-- Extend the declared location span of a 'HdkA' computation: +-- +-- left_neighbour <*> extendHdkA l x <*> right_neighbour +-- +-- The declared location of 'x' now includes 'l', so that the surrounding +-- computations 'left_neighbour' and 'right_neighbour' will not look for +-- Haddock comments inside the 'l' location span. +extendHdkA :: SrcSpan -> HdkA a -> HdkA a +extendHdkA l' (HdkA l m) = HdkA (getBufSpan l' <> l) m + + +{- ********************************************************************* +* * +* HdkM: a stateful computation to associate * +* accumulated documentation comments with AST nodes * +* * +********************************************************************* -} + +-- The state of 'HdkM' contains a list of pending Haddock comments. We go +-- over the AST, looking up these comments using 'takeHdkComments' and removing +-- them from the state. The remaining, un-removed ones are ignored with a +-- warning (-Winvalid-haddock). Also, using a state means we never use the same +-- Haddock twice. +-- +-- See Note [Adding Haddock comments to the syntax tree]. +newtype HdkM a = HdkM (ReaderT LocRange (State HdkSt) a) + deriving (Functor, Applicative, Monad) + +-- | The state of HdkM. +data HdkSt = + HdkSt + { hdk_st_pending :: [PsLocated HdkComment] + -- a list of pending (unassociated with an AST node) + -- Haddock comments, sorted by location: in ascending order of the starting 'BufPos' + , hdk_st_warnings :: [HdkWarn] + -- accumulated warnings (order doesn't matter) + } + +-- | Warnings accumulated in HdkM. +data HdkWarn + = HdkWarnInvalidComment (PsLocated HdkComment) + | HdkWarnExtraComment LHsDocString + +-- 'HdkM' without newtype wrapping/unwrapping. +type InlineHdkM a = LocRange -> HdkSt -> (a, HdkSt) + +mkHdkM :: InlineHdkM a -> HdkM a +unHdkM :: HdkM a -> InlineHdkM a +mkHdkM = coerce +unHdkM = coerce + +-- Restrict the range in which a HdkM computation will look up comments: +-- +-- inLocRange r1 $ +-- inLocRange r2 $ +-- takeHdkComments ... -- Only takes comments in the (r1 <> r2) location range. +-- +-- Note that it does not blindly override the range but tightens it using (<>). +-- At many use sites, you will see something along the lines of: +-- +-- inLocRange (locRangeTo end_pos) $ ... +-- +-- And 'locRangeTo' defines a location range from the start of the file to +-- 'end_pos'. This does not mean that we now search for every comment from the +-- start of the file, as this restriction will be combined with other +-- restrictions. Somewhere up the callstack we might have: +-- +-- inLocRange (locRangeFrom start_pos) $ ... +-- +-- The net result is that the location range is delimited by 'start_pos' on +-- one side and by 'end_pos' on the other side. +-- +-- In 'HdkA', every (<*>) may restrict the location range of its +-- subcomputations. +inLocRange :: LocRange -> HdkM a -> HdkM a +inLocRange r (HdkM m) = HdkM (local (mappend r) m) + +-- Take the Haddock comments that satisfy the matching function, +-- leaving the rest pending. +takeHdkComments :: forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a] +takeHdkComments f = + mkHdkM $ + \(LocRange hdk_from hdk_to hdk_col) -> + \hdk_st -> + let + comments = hdk_st_pending hdk_st + (comments_before_range, comments') = break (is_after hdk_from) comments + (comments_in_range, comments_after_range) = span (is_before hdk_to <&&> is_indented hdk_col) comments' + (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') + where + is_after StartOfFile _ = True + is_after (StartLoc l) (L l_comment _) = bufSpanStart (psBufSpan l_comment) >= l + is_before EndOfFile _ = True + is_before (EndLoc l) (L l_comment _) = bufSpanStart (psBufSpan l_comment) <= l + is_indented (ColumnFrom n) (L l_comment _) = srcSpanStartCol (psRealSpan l_comment) >= n + + add_comment + :: PsLocated HdkComment + -> ([a], [PsLocated HdkComment]) + -> ([a], [PsLocated HdkComment]) + add_comment hdk_comment (items, other_hdk_comments) = + case f hdk_comment of + Just item -> (item : items, other_hdk_comments) + 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 l = do + let (l_start, l_end) = (srcSpanStart l, srcSpanEnd l) + before_t = locRangeTo (getBufPos l_start) + after_t = locRangeFrom (getBufPos l_end) + nextDocs <- inLocRange before_t $ takeHdkComments mkDocNext + prevDocs <- inLocRange after_t $ takeHdkComments mkDocPrev + selectDocString (nextDocs ++ prevDocs) + +appendHdkWarning :: HdkWarn -> HdkM () +appendHdkWarning e = HdkM (ReaderT (\_ -> modify append_warn)) + where + append_warn hdk_st = hdk_st { hdk_st_warnings = e : hdk_st_warnings hdk_st } + +selectDocString :: [LHsDocString] -> HdkM (Maybe LHsDocString) +selectDocString = select . filterOut (isEmptyDocString . unLoc) + where + select [] = return Nothing + select [doc] = return (Just doc) + select (doc : extra_docs) = do + reportExtraDocs extra_docs + return (Just doc) + +reportExtraDocs :: [LHsDocString] -> HdkM () +reportExtraDocs = + traverse_ (\extra_doc -> appendHdkWarning (HdkWarnExtraComment extra_doc)) + +{- ********************************************************************* +* * +* Matching functions for extracting documentation comments * +* * +********************************************************************* -} + +mkDocHsDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) +mkDocHsDecl layout_info a = mapLoc (DocD noExtField) <$> mkDocDecl layout_info a + +mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe LDocDecl +mkDocDecl layout_info (L l_comment hdk_comment) + | indent_mismatch = Nothing + | otherwise = + Just $ L (mkSrcSpanPs l_comment) $ + case hdk_comment of + HdkCommentNext doc -> DocCommentNext doc + HdkCommentPrev doc -> DocCommentPrev doc + HdkCommentNamed s doc -> DocCommentNamed s doc + HdkCommentSection n doc -> DocGroup n doc + where + -- 'indent_mismatch' checks if the documentation comment has the exact + -- indentation level expected by the parent node. + -- + -- For example, when extracting documentation comments between class + -- method declarations, there are three cases to consider: + -- + -- 1. Indent matches (indent_mismatch=False): + -- class C a where + -- f :: a -> a + -- -- ^ doc on f + -- + -- 2. Indented too much (indent_mismatch=True): + -- class C a where + -- f :: a -> a + -- -- ^ indent mismatch + -- + -- 3. Indented too little (indent_mismatch=True): + -- class C a where + -- f :: a -> a + -- -- ^ indent mismatch + indent_mismatch = case layout_info of + NoLayoutInfo -> False + ExplicitBraces -> False + VirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_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) + HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s) + HdkCommentNext doc -> Just $ L l (IEDoc noExtField doc) + _ -> Nothing + where l = mkSrcSpanPs l_comment + +mkDocNext :: PsLocated HdkComment -> Maybe LHsDocString +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 _ = Nothing + + +{- ********************************************************************* +* * +* LocRange: a location range * +* * +********************************************************************* -} + +-- A location range for extracting documentation comments. +data LocRange = + LocRange + { loc_range_from :: !LowerLocBound, + loc_range_to :: !UpperLocBound, + loc_range_col :: !ColumnBound } + +instance Semigroup LocRange where + LocRange from1 to1 col1 <> LocRange from2 to2 col2 = + LocRange (from1 <> from2) (to1 <> to2) (col1 <> col2) + +instance Monoid LocRange where + mempty = LocRange mempty mempty mempty + +-- The location range from the specified position to the end of the file. +locRangeFrom :: Maybe BufPos -> LocRange +locRangeFrom (Just l) = mempty { loc_range_from = StartLoc l } +locRangeFrom Nothing = mempty + +-- The location range from the start of the file to the specified position. +locRangeTo :: Maybe BufPos -> LocRange +locRangeTo (Just l) = mempty { loc_range_to = EndLoc l } +locRangeTo Nothing = mempty + +-- Represents a predicate on BufPos: +-- +-- LowerLocBound | BufPos -> Bool +-- --------------+----------------- +-- StartOfFile | const True +-- StartLoc p | (>= p) +-- +-- The semigroup instance corresponds to (&&). +-- +-- We don't use the BufPos -> Bool representation +-- as it would lead to redundant checks. +-- +-- That is, instead of +-- +-- (pos >= 20) && (pos >= 30) && (pos >= 40) +-- +-- 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 + +instance Semigroup LowerLocBound where + StartOfFile <> l = l + l <> StartOfFile = l + StartLoc l1 <> StartLoc l2 = StartLoc (max l1 l2) + +instance Monoid LowerLocBound where + mempty = StartOfFile + +-- Represents a predicate on BufPos: +-- +-- UpperLocBound | BufPos -> Bool +-- --------------+----------------- +-- EndOfFile | const True +-- EndLoc p | (<= p) +-- +-- The semigroup instance corresponds to (&&). +-- +-- We don't use the BufPos -> Bool representation +-- as it would lead to redundant checks. +-- +-- That is, instead of +-- +-- (pos <= 40) && (pos <= 30) && (pos <= 20) +-- +-- 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 + +instance Semigroup UpperLocBound where + EndOfFile <> l = l + l <> EndOfFile = l + EndLoc l1 <> EndLoc l2 = EndLoc (min l1 l2) + +instance Monoid UpperLocBound where + mempty = EndOfFile + +-- | Represents a predicate on the column number. +-- +-- ColumnBound | Int -> Bool +-- --------------+----------------- +-- ColumnFrom n | (>=n) +-- +-- The semigroup instance corresponds to (&&). +-- +newtype ColumnBound = ColumnFrom Int -- n >= GHC.Types.SrcLoc.leftmostColumn + +instance Semigroup ColumnBound where + ColumnFrom n <> ColumnFrom m = ColumnFrom (max n m) + +instance Monoid ColumnBound where + mempty = ColumnFrom leftmostColumn + + +{- ********************************************************************* +* * +* AST manipulation utilities * +* * +********************************************************************* -} + +mkLHsDocTy :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs +mkLHsDocTy t Nothing = t +mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noExtField t doc) + +getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan +getForAllTeleLoc tele = + foldr combineSrcSpans noSrcSpan $ + case tele of + HsForAllVis{ hsf_vis_bndrs } -> map getLoc hsf_vis_bndrs + HsForAllInvis { hsf_invis_bndrs } -> map getLoc hsf_invis_bndrs + +-- | The inverse of 'partitionBindsAndSigs' that merges partitioned items back +-- into a flat list. Elements are put back into the order in which they +-- appeared in the original program before partitioning, using BufPos to order +-- them. +-- +-- Precondition (unchecked): the input lists are already sorted. +flattenBindsAndSigs + :: (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], + [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) + -> [LHsDecl GhcPs] +flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) = + -- 'cmpBufSpan' is safe here with the following assumptions: + -- + -- * 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan' + -- * 'partitionBindsAndSigs' does not discard this 'BufSpan' + mergeListsBy cmpBufSpan [ + mapLL (\b -> ValD noExtField b) (bagToList all_bs), + mapLL (\s -> SigD noExtField s) all_ss, + mapLL (\t -> TyClD noExtField (FamDecl noExtField t)) all_ts, + mapLL (\tfi -> InstD noExtField (TyFamInstD noExtField tfi)) all_tfis, + mapLL (\dfi -> InstD noExtField (DataFamInstD noExtField dfi)) all_dfis, + mapLL (\d -> DocD noExtField d) all_docs + ] + +{- ********************************************************************* +* * +* General purpose utilities * +* * +********************************************************************* -} + +-- Cons an element to a list, if exists. +mcons :: Maybe a -> [a] -> [a] +mcons = maybe id (:) + +-- Map a function over a list of located items. +mapLL :: (a -> b) -> [Located a] -> [Located b] +mapLL f = map (mapLoc f) + +{- Note [Old solution: Haddock in the grammar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the past, Haddock comments were incorporated into the grammar (Parser.y). +This led to excessive complexity and duplication. + +For example, here's the grammar production for types without documentation: + + type : btype + | btype '->' ctype + +To support Haddock, we had to also maintain an additional grammar production +for types with documentation on function arguments and function result: + + typedoc : btype + | btype docprev + | docnext btype + | btype '->' ctypedoc + | btype docprev '->' ctypedoc + | docnext btype '->' ctypedoc + +Sometimes handling documentation comments during parsing led to bugs (#17561), +and sometimes it simply made it hard to modify and extend the grammar. + +Another issue was that sometimes Haddock would fail to parse code +that GHC could parse succesfully: --- ----------------------------------------------------------------------------- --- Adding documentation to record fields (used in parsing). + class BadIndent where + f :: a -> Int + -- ^ comment + g :: a -> Int -addFieldDoc :: LConDeclField GhcPs -> Maybe LHsDocString -> LConDeclField GhcPs -addFieldDoc (L l fld) doc - = L l (fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }) +This declaration was accepted by ghc but rejected by ghc -haddock. +-} -addFieldDocs :: [LConDeclField GhcPs] -> Maybe LHsDocString -> [LConDeclField GhcPs] -addFieldDocs [] _ = [] -addFieldDocs (x:xs) doc = addFieldDoc x doc : xs +{- Note [Register keyword location] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment, 'addHaddock' erroneously associates some comments with +constructs that are separated by a keyword. For example: + data Foo -- | Comment for MkFoo + where MkFoo :: Foo -addConDoc :: LConDecl GhcPs -> Maybe LHsDocString -> LConDecl GhcPs -addConDoc decl Nothing = decl -addConDoc (L p c) doc = L p $ case c of - ConDeclH98 { con_doc = old_doc } -> c { con_doc = old_doc `mplus` doc } - ConDeclGADT { con_doc = old_doc } -> c { con_doc = old_doc `mplus` doc } - XConDecl x@(ConDeclGADTPrefixPs { con_gp_doc = old_doc }) -> - XConDecl (x { con_gp_doc = old_doc `mplus` doc }) +The issue stems from the lack of location information for keywords. We could +utilize API Annotations for this purpose, but not without modification. For +example, API Annotations operate on RealSrcSpan, whereas we need BufSpan. -addConDocs :: [LConDecl GhcPs] -> Maybe LHsDocString -> [LConDecl GhcPs] -addConDocs [] _ = [] -addConDocs [x] doc = [addConDoc x doc] -addConDocs (x:xs) doc = x : addConDocs xs doc +Also, there's work towards making API Annotations available in-tree (not in +a separate Map), see #17638. This change should make the fix very easy (it +is not as easy with the current design). -addConDocFirst :: [LConDecl GhcPs] -> Maybe LHsDocString -> [LConDecl GhcPs] -addConDocFirst [] _ = [] -addConDocFirst (x:xs) doc = addConDoc x doc : xs +See also testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs +-} diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 0145c6c776..277a6fec7d 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -206,7 +206,7 @@ tcRnModuleTcRnM :: HscEnv tcRnModuleTcRnM hsc_env mod_sum (HsParsedModule { hpm_module = - (L loc (HsModule maybe_mod export_ies + (L loc (HsModule _ maybe_mod export_ies import_decls local_decls mod_deprec maybe_doc_hdr)), hpm_src_files = src_files diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 58add2b135..82ea8b97fe 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -270,7 +270,7 @@ cvtDec (ClassD ctxt cl tvs fds decs) <+> text "are not allowed:") $$ (Outputable.ppr adts')) ; returnJustL $ TyClD noExtField $ - ClassDecl { tcdCExt = noExtField + ClassDecl { tcdCExt = NoLayoutInfo , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs index 00bf00ac2c..2ac2a13b04 100644 --- a/compiler/GHC/Types/SrcLoc.hs +++ b/compiler/GHC/Types/SrcLoc.hs @@ -69,7 +69,9 @@ module GHC.Types.SrcLoc ( -- * StringBuffer locations BufPos(..), + getBufPos, BufSpan(..), + getBufSpan, -- * Located Located, @@ -88,10 +90,11 @@ module GHC.Types.SrcLoc ( mapLoc, -- ** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, + eqLocated, cmpLocated, cmpBufSpan, + combineLocs, addCLoc, leftmost_smallest, leftmost_largest, rightmost_smallest, - spans, isSubspanOf, isRealSubspanOf, sortLocated, - sortRealLocated, + spans, isSubspanOf, isRealSubspanOf, + sortLocated, sortRealLocated, lookupSrcLoc, lookupSrcSpan, liftL, @@ -106,6 +109,10 @@ module GHC.Types.SrcLoc ( psSpanEnd, mkSrcSpanPs, + -- * Layout information + LayoutInfo(..), + leftmostColumn + ) where import GHC.Prelude @@ -122,6 +129,7 @@ import Data.Data import Data.List (sortBy, intercalate) import Data.Function (on) import qualified Data.Map as Map +import qualified Data.Semigroup {- ************************************************************************ @@ -143,13 +151,77 @@ data RealSrcLoc {-# UNPACK #-} !Int -- column number, begins at 1 deriving (Eq, Ord) --- | 0-based index identifying the raw location in the StringBuffer. +-- | 0-based offset identifying the raw location in the 'StringBuffer'. +-- +-- The lexer increments the 'BufPos' every time a character (UTF-8 code point) +-- is read from the input buffer. As UTF-8 is a variable-length encoding and +-- 'StringBuffer' needs a byte offset for indexing, a 'BufPos' cannot be used +-- for indexing. +-- +-- The parser guarantees that 'BufPos' are monotonic. See #17632. This means +-- that syntactic constructs that appear later in the 'StringBuffer' are guaranteed to +-- have a higher 'BufPos'. Constrast that with 'RealSrcLoc', which does *not* make the +-- analogous guarantee about higher line/column numbers. +-- +-- This is due to #line and {-# LINE ... #-} pragmas that can arbitrarily +-- modify 'RealSrcLoc'. Notice how 'setSrcLoc' and 'resetAlrLastLoc' in +-- "GHC.Parser.Lexer" update 'PsLoc', modifying 'RealSrcLoc' but preserving +-- 'BufPos'. +-- +-- Monotonicity makes 'BufPos' useful to determine the order in which syntactic +-- elements appear in the source. Consider this example (haddockA041 in the test suite): +-- +-- haddockA041.hs +-- {-# LANGUAGE CPP #-} +-- -- | Module header documentation +-- module Comments_and_CPP_include where +-- #include "IncludeMe.hs" +-- +-- IncludeMe.hs: +-- -- | Comment on T +-- data T = MkT -- ^ Comment on MkT +-- +-- After the C preprocessor runs, the 'StringBuffer' will contain a program that +-- looks like this (unimportant lines at the beginning removed): +-- +-- # 1 "haddockA041.hs" +-- {-# LANGUAGE CPP #-} +-- -- | Module header documentation +-- module Comments_and_CPP_include where +-- # 1 "IncludeMe.hs" 1 +-- -- | Comment on T +-- data T = MkT -- ^ Comment on MkT +-- # 7 "haddockA041.hs" 2 +-- +-- The line pragmas inserted by CPP make the error messages more informative. +-- The downside is that we can't use RealSrcLoc to determine the ordering of +-- syntactic elements. +-- +-- With RealSrcLoc, we have the following location information recorded in the AST: +-- * The module name is located at haddockA041.hs:3:8-31 +-- * The Haddock comment "Comment on T" is located at IncludeMe:1:1-17 +-- * The data declaration is located at IncludeMe.hs:2:1-32 -- --- Unlike 'RealSrcLoc', it is not affected by #line and {-# LINE ... #-} --- pragmas. In particular, notice how 'setSrcLoc' and 'resetAlrLastLoc' in --- "GHC.Parser.Lexer" update 'PsLoc' preserving 'BufPos'. +-- Is the Haddock comment located between the module name and the data +-- declaration? This is impossible to tell because the locations are not +-- comparable; they even refer to different files. -- --- The parser guarantees that 'BufPos' are monotonic. See #17632. +-- On the other hand, with 'BufPos', we have the following location information: +-- * The module name is located at 846-870 +-- * The Haddock comment "Comment on T" is located at 898-915 +-- * The data declaration is located at 916-928 +-- +-- Aside: if you're wondering why the numbers are so high, try running +-- @ghc -E haddockA041.hs@ +-- and see the extra fluff that CPP inserts at the start of the file. +-- +-- For error messages, 'BufPos' is not useful at all. On the other hand, this is +-- exactly what we need to determine the order of syntactic elements: +-- 870 < 898, therefore the Haddock comment appears *after* the module name. +-- 915 < 916, therefore the Haddock comment appears *before* the data declaration. +-- +-- 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) @@ -173,6 +245,10 @@ mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc mkRealSrcLoc x line col = SrcLoc x line col +getBufPos :: SrcLoc -> Maybe BufPos +getBufPos (RealSrcLoc _ mbpos) = mbpos +getBufPos (UnhelpfulLoc _) = Nothing + -- | Built-in "bad" 'SrcLoc' values for particular locations noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc noSrcLoc = UnhelpfulLoc (fsLit "<no location info>") @@ -298,6 +374,10 @@ data BufSpan = BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos } deriving (Eq, Ord, Show) +instance Semigroup BufSpan where + BufSpan start1 end1 <> BufSpan start2 end2 = + BufSpan (min start1 start2) (max end1 end2) + -- | Source Span -- -- A 'SrcSpan' identifies either a specific portion of a text file @@ -352,6 +432,10 @@ instance ToJson RealSrcSpan where instance NFData SrcSpan where rnf x = x `seq` () +getBufSpan :: SrcSpan -> Maybe BufSpan +getBufSpan (RealSrcSpan _ mbspan) = mbspan +getBufSpan (UnhelpfulSpan _) = Nothing + -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan noSrcSpan = UnhelpfulSpan UnhelpfulNoLocationInfo @@ -674,6 +758,17 @@ eqLocated a b = unLoc a == unLoc b cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering cmpLocated a b = unLoc a `compare` unLoc b +-- | Compare the 'BufSpan' of two located things. +-- +-- Precondition: both operands have an associated 'BufSpan'. +cmpBufSpan :: HasDebugCallStack => Located a -> Located a -> Ordering +cmpBufSpan (L l1 _) (L l2 _) + | Just a <- getBufSpan l1 + , Just b <- getBufSpan l2 + = compare a b + + | otherwise = panic "cmpBufSpan: no BufSpan" + instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where ppr (L l e) = -- TODO: We can't do this since Located was refactored into -- GenLocated: @@ -768,3 +863,33 @@ psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b) mkSrcSpanPs :: PsSpan -> SrcSpan mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Just b) + +-- | Layout information for declarations. +data LayoutInfo = + + -- | Explicit braces written by the user. + -- + -- @ + -- class C a where { foo :: a; bar :: a } + -- @ + ExplicitBraces + | + -- | Virtual braces inserted by the layout algorithm. + -- + -- @ + -- class C a where + -- foo :: a + -- bar :: a + -- @ + VirtualBraces + !Int -- ^ Layout column (indentation level, begins at 1) + | + -- | Empty or compiler-generated blocks do not have layout information + -- associated with them. + NoLayoutInfo + + deriving (Eq, Ord, Show, Data) + +-- | Indentation level is 1-indexed, so the leftmost column is 1. +leftmostColumn :: Int +leftmostColumn = 1 diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index 6f0c0a6aa5..e0ef6abd0a 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -49,9 +50,13 @@ module GHC.Utils.Misc ( chunkList, changeLast, + mapLastM, whenNonEmpty, + mergeListsBy, + isSortedBy, + -- * Tuples fstOf3, sndOf3, thdOf3, firstM, first3M, secondM, @@ -601,10 +606,65 @@ changeLast [] _ = panic "changeLast" changeLast [_] x = [x] changeLast (x:xs) x' = x : changeLast xs x' +-- | Apply an effectful function to the last list element. +-- Assumes a non-empty list (panics otherwise). +mapLastM :: Functor f => (a -> f a) -> [a] -> f [a] +mapLastM _ [] = panic "mapLastM: empty list" +mapLastM f [x] = (\x' -> [x']) <$> f x +mapLastM f (x:xs) = (x:) <$> mapLastM f xs + whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty [] _ = pure () whenNonEmpty (x:xs) f = f (x :| xs) +-- | Merge an unsorted list of sorted lists, for example: +-- +-- > mergeListsBy compare [ [2,5,15], [1,10,100] ] = [1,2,5,10,15,100] +-- +-- \( O(n \log{} k) \) +mergeListsBy :: forall a. (a -> a -> Ordering) -> [[a]] -> [a] +mergeListsBy cmp lists | debugIsOn, not (all sorted lists) = + -- When debugging is on, we check that the input lists are sorted. + panic "mergeListsBy: input lists must be sorted" + where sorted = isSortedBy cmp +mergeListsBy cmp all_lists = merge_lists all_lists + where + -- Implements "Iterative 2-Way merge" described at + -- https://en.wikipedia.org/wiki/K-way_merge_algorithm + + -- Merge two sorted lists into one in O(n). + merge2 :: [a] -> [a] -> [a] + merge2 [] ys = ys + merge2 xs [] = xs + merge2 (x:xs) (y:ys) = + case cmp x y of + GT -> y : merge2 (x:xs) ys + _ -> x : merge2 xs (y:ys) + + -- Merge the first list with the second, the third with the fourth, and so + -- on. The output has half as much lists as the input. + merge_neighbours :: [[a]] -> [[a]] + merge_neighbours [] = [] + merge_neighbours [xs] = [xs] + merge_neighbours (xs : ys : lists) = + merge2 xs ys : merge_neighbours lists + + -- Since 'merge_neighbours' halves the amount of lists in each iteration, + -- we perform O(log k) iteration. Each iteration is O(n). The total running + -- time is therefore O(n log k). + merge_lists :: [[a]] -> [a] + merge_lists lists = + case merge_neighbours lists of + [] -> [] + [xs] -> xs + lists' -> merge_lists lists' + +isSortedBy :: (a -> a -> Ordering) -> [a] -> Bool +isSortedBy cmp = sorted + where + sorted [] = True + sorted [_] = True + sorted (x:y:xs) = cmp x y /= GT && sorted (y:xs) {- ************************************************************************ * * diff --git a/docs/users_guide/8.12.1-notes.rst b/docs/users_guide/8.12.1-notes.rst index d393c6a381..1fe2e49894 100644 --- a/docs/users_guide/8.12.1-notes.rst +++ b/docs/users_guide/8.12.1-notes.rst @@ -290,6 +290,46 @@ Arrow notation within 0.5 -< x ... |) +Haddock +~~~~~~~ + +- Parsing is now more robust to insufficiently indented Haddock comments:: + + class C a where + f :: a -> a + -- ^ This comment used to trigger a parse error + g :: a -> a + +- :ghc-flag:`-Winvalid-haddock` is a new warning that reports discarded Haddock + comments that cannot be associated with AST elements:: + + myValue = + -- | Invalid (discarded) comment in an expression + 2 + 2 + +- When faced with several comments for a data constructor or a data constructor + field, Haddock now picks the first one instead of the last one. The + extraneous comment is reported as invalid when :ghc-flag:`-Winvalid-haddock` + is enabled:: + + data T + -- | First comment + = MkT + -- ^ Second comment (rejected) + + +- Haddock is now more relaxed about the placement of comments in types relative + to the function arrow ``->``, allowing more formatting styles:: + + f :: Int -> -- ^ comment on Int (no longer a parse error) + Bool -- ^ comment on Bool + +- Haddock can now parse the documentation comment for the first declaration in + a module without a module header (:ghc-ticket:`17561`):: + + -- | This comment used to trigger a parse error + main = putStrLn "Hello" + ``ghc-prim`` library ~~~~~~~~~~~~~~~~~~~~ @@ -330,6 +370,10 @@ Arrow notation erased, and their ``exceptions``-alternatives are meant to be used in the GHC code instead. +- ``parseModule`` is now the only parser entry point that deals with Haddock + comments. The other entry points (``parseDeclaration``, ``parseExpression``, + etc) do not insert the Haddock comments into the AST. + ``base`` library ~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst index 256d143f45..a83cc6837e 100644 --- a/docs/users_guide/using-warnings.rst +++ b/docs/users_guide/using-warnings.rst @@ -1762,6 +1762,25 @@ of ``-W(no-)*``. You may want to enable this warning on a clean build or enable :ghc-flag:`-fforce-recomp` in order to get reliable results. +.. ghc-flag:: -Winvalid-haddock + :shortdesc: warn when a Haddock comment occurs in an invalid position + :type: dynamic + :category: + + :since: 8.12 + + When the ``-haddock`` option is enabled, GHC collects documentation + comments and associates them with declarations, function arguments, data + constructors, and other syntactic elements. Documentation comments in + invalid positions are discarded:: + + myValue = + -- | Invalid (discarded) comment in an expression + 2 + 2 + + This warning informs you about discarded documentation comments. + It has no effect when :ghc-flag:`-haddock` is disabled. + If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice. It turns on heavyweight intra-pass sanity-checking within GHC. (It checks GHC's sanity, not yours.) diff --git a/testsuite/tests/ghc-api/T11579.hs b/testsuite/tests/ghc-api/T11579.hs index 7ea08c9216..9f1cc41f92 100644 --- a/testsuite/tests/ghc-api/T11579.hs +++ b/testsuite/tests/ghc-api/T11579.hs @@ -5,6 +5,7 @@ import GHC import GHC.Data.StringBuffer import GHC.Parser.Lexer import GHC.Types.SrcLoc +import Data.Foldable (toList) main :: IO () main = do @@ -13,14 +14,14 @@ main = do let stringBuffer = stringToStringBuffer "-- $bar some\n-- named chunk" loc = mkRealSrcLoc (mkFastString "Foo.hs") 1 1 - token <- runGhc (Just libdir) $ do + hdk_comments <- runGhc (Just libdir) $ do dflags <- getSessionDynFlags let pstate = mkPState (dflags `gopt_set` Opt_Haddock) stringBuffer loc case unP (lexer False return) pstate of - POk _ token -> return (unLoc token) - _ -> error "No token" + POk s (L _ ITeof) -> return (map unLoc (toList (hdk_comments s))) + _ -> error "No token" -- #11579 -- Expected: "ITdocCommentNamed "bar some\n named chunk" -- Actual (with ghc-8.0.1-rc2): "ITdocCommentNamed "bar some" - print token + mapM_ print hdk_comments diff --git a/testsuite/tests/ghc-api/T11579.stdout b/testsuite/tests/ghc-api/T11579.stdout index 7603e535e7..24f3bf52e5 100644 --- a/testsuite/tests/ghc-api/T11579.stdout +++ b/testsuite/tests/ghc-api/T11579.stdout @@ -1 +1 @@ -ITdocCommentNamed "bar some\n named chunk" +HdkCommentNamed "bar" (HsDocString " some\n named chunk") diff --git a/testsuite/tests/ghc-api/annotations/comments.stdout b/testsuite/tests/ghc-api/annotations/comments.stdout index 06273ba1e6..e5ff216fb0 100644 --- a/testsuite/tests/ghc-api/annotations/comments.stdout +++ b/testsuite/tests/ghc-api/annotations/comments.stdout @@ -1,12 +1,11 @@ [ -( CommentsTest.hs:11:1-33 = -[(CommentsTest.hs:11:1-33,AnnDocCommentNext " The function @foo@ does blah")]) - ( CommentsTest.hs:(12,7)-(15,14) = [(CommentsTest.hs:14:15-24,AnnLineComment "-- value 2")]) ( <no location info> = -[(CommentsTest.hs:(3,1)-(7,2),AnnBlockComment "{-\nAn opening comment\n {- with a nested one -}\n {-# nested PRAGMA #-}\n-}"), +[(CommentsTest.hs:11:1-33,AnnDocCommentNext " The function @foo@ does blah"), + +(CommentsTest.hs:(3,1)-(7,2),AnnBlockComment "{-\nAn opening comment\n {- with a nested one -}\n {-# nested PRAGMA #-}\n-}"), (CommentsTest.hs:1:1-31,AnnBlockComment "{-# LANGUAGE DeriveFoldable #-}")]) ] diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.hs b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.hs index 5e7369cdc0..52899930be 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.hs +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -7,6 +8,11 @@ module T11768 where class C a b +class D a + +newtype DWrapper a = DWrap a +instance D (DWrapper a) + data Foo = Foo deriving Eq -- ^ Documenting a single type @@ -15,6 +21,7 @@ data Bar = Bar , Ord ) deriving anyclass ( forall a. C a {- ^ Documenting forall type -} ) + deriving D {- ^ Documenting deriving via -} via DWrapper Bar -- | Documenting a standalone deriving instance deriving instance Read Bar diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr index 6de1b2b851..5fe63362b1 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr @@ -2,6 +2,9 @@ ==================== Parser ==================== module T11768 where class C a b +class D a +newtype DWrapper a = DWrap a +instance D (DWrapper a) data Foo = Foo deriving Eq " Documenting a single type" @@ -9,6 +12,7 @@ data Bar = Bar deriving (Eq " Documenting one of multiple types", Ord) deriving anyclass (forall a. C a " Documenting forall type ") + deriving D " Documenting deriving via " via DWrapper Bar <document comment> deriving instance Read Bar diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.hs b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.hs new file mode 100644 index 0000000000..884bb2f495 --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE TypeFamilies, GADTSyntax #-} + +module T17544 where + +class C1 a where + f1 :: a -> Int + -- ^ comment on Int + +class C2 a where + f2 :: a -> Int + -- ^ comment on f2 + +class C3 a where + f3 :: a -> Int +-- ^ comment on C3 + +class C4 a where + f4 :: a -> Int +-- ^ comment + g4 :: a -> Int + +class C5 a where { data D5 a } +instance C5 Int where + data D5 Int where + MkD5 :: D5 Int + -- ^ comment on D5 Int + +class C6 a where { data D6 a } +instance C6 Int where + data D6 Int where + MkD6 :: D6 Int + -- ^ comment on MkD6 + +class C7 a where { data D7 a } +instance C7 Int where + data D7 Int where + MkD7 :: D7 Int + -- ^ comment on data instance D7 Int + +class C8 a where { data D8 a } +instance C8 Int where + data D8 Int where + MkD8 :: D8 Int + -- ^ comment on data instance D8 Int + +class C9 a where { data D9 a } +instance C9 Int where + data D9 Int where + MkD9 :: D9 Int + -- ^ comment on class instance C9 Int + +class C10 a where { data D10 a } +instance C10 Int where + data D10 Int where + MkD10 :: D10 Int +-- ^ comment on class instance C10 Int diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr new file mode 100644 index 0000000000..863015241f --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr @@ -0,0 +1,1090 @@ + +==================== Parser AST ==================== + +({ T17544.hs:1:1 } + (HsModule + (VirtualBraces + (1)) + (Just + ({ T17544.hs:3:8-13 } + {ModuleName: T17544})) + (Nothing) + [] + [({ T17544.hs:(5,1)-(6,16) } + (TyClD + (NoExtField) + (ClassDecl + (VirtualBraces + (3)) + ({ <no location info> } + []) + ({ T17544.hs:5:7-8 } + (Unqual + {OccName: C1})) + (HsQTvs + (NoExtField) + [({ T17544.hs:5:10 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:5:10 } + (Unqual + {OccName: a}))))]) + (Prefix) + [] + [({ T17544.hs:6:3-16 } + (ClassOpSig + (NoExtField) + (False) + [({ T17544.hs:6:3-4 } + (Unqual + {OccName: f1}))] + (HsIB + (NoExtField) + ({ T17544.hs:6:9-16 } + (HsFunTy + (NoExtField) + (HsUnrestrictedArrow) + ({ T17544.hs:6:9 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:6:9 } + (Unqual + {OccName: a})))) + ({ T17544.hs:6:14-16 } + (HsDocTy + (NoExtField) + ({ T17544.hs:6:14-16 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:6:14-16 } + (Unqual + {OccName: Int})))) + ({ T17544.hs:7:5-23 } + (HsDocString + " comment on Int")))))))))] + {Bag(Located (HsBind GhcPs)): + []} + [] + [] + []))) + ,({ T17544.hs:(9,1)-(10,16) } + (TyClD + (NoExtField) + (ClassDecl + (VirtualBraces + (3)) + ({ <no location info> } + []) + ({ T17544.hs:9:7-8 } + (Unqual + {OccName: C2})) + (HsQTvs + (NoExtField) + [({ T17544.hs:9:10 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:9:10 } + (Unqual + {OccName: a}))))]) + (Prefix) + [] + [({ T17544.hs:10:3-16 } + (ClassOpSig + (NoExtField) + (False) + [({ T17544.hs:10:3-4 } + (Unqual + {OccName: f2}))] + (HsIB + (NoExtField) + ({ T17544.hs:10:9-16 } + (HsFunTy + (NoExtField) + (HsUnrestrictedArrow) + ({ T17544.hs:10:9 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:10:9 } + (Unqual + {OccName: a})))) + ({ T17544.hs:10:14-16 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:10:14-16 } + (Unqual + {OccName: Int})))))))))] + {Bag(Located (HsBind GhcPs)): + []} + [] + [] + [({ T17544.hs:11:3-20 } + (DocCommentPrev + (HsDocString + " comment on f2")))]))) + ,({ T17544.hs:(13,1)-(14,16) } + (TyClD + (NoExtField) + (ClassDecl + (VirtualBraces + (3)) + ({ <no location info> } + []) + ({ T17544.hs:13:7-8 } + (Unqual + {OccName: C3})) + (HsQTvs + (NoExtField) + [({ T17544.hs:13:10 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:13:10 } + (Unqual + {OccName: a}))))]) + (Prefix) + [] + [({ T17544.hs:14:3-16 } + (ClassOpSig + (NoExtField) + (False) + [({ T17544.hs:14:3-4 } + (Unqual + {OccName: f3}))] + (HsIB + (NoExtField) + ({ T17544.hs:14:9-16 } + (HsFunTy + (NoExtField) + (HsUnrestrictedArrow) + ({ T17544.hs:14:9 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:14:9 } + (Unqual + {OccName: a})))) + ({ T17544.hs:14:14-16 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:14:14-16 } + (Unqual + {OccName: Int})))))))))] + {Bag(Located (HsBind GhcPs)): + []} + [] + [] + []))) + ,({ T17544.hs:15:1-18 } + (DocD + (NoExtField) + (DocCommentPrev + (HsDocString + " comment on C3")))) + ,({ T17544.hs:(17,1)-(20,16) } + (TyClD + (NoExtField) + (ClassDecl + (VirtualBraces + (3)) + ({ <no location info> } + []) + ({ T17544.hs:17:7-8 } + (Unqual + {OccName: C4})) + (HsQTvs + (NoExtField) + [({ T17544.hs:17:10 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:17:10 } + (Unqual + {OccName: a}))))]) + (Prefix) + [] + [({ T17544.hs:18:3-16 } + (ClassOpSig + (NoExtField) + (False) + [({ T17544.hs:18:3-4 } + (Unqual + {OccName: f4}))] + (HsIB + (NoExtField) + ({ T17544.hs:18:9-16 } + (HsFunTy + (NoExtField) + (HsUnrestrictedArrow) + ({ T17544.hs:18:9 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:18:9 } + (Unqual + {OccName: a})))) + ({ T17544.hs:18:14-16 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:18:14-16 } + (Unqual + {OccName: Int}))))))))) + ,({ T17544.hs:20:3-16 } + (ClassOpSig + (NoExtField) + (False) + [({ T17544.hs:20:3-4 } + (Unqual + {OccName: g4}))] + (HsIB + (NoExtField) + ({ T17544.hs:20:9-16 } + (HsFunTy + (NoExtField) + (HsUnrestrictedArrow) + ({ T17544.hs:20:9 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:20:9 } + (Unqual + {OccName: a})))) + ({ T17544.hs:20:14-16 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:20:14-16 } + (Unqual + {OccName: Int})))))))))] + {Bag(Located (HsBind GhcPs)): + []} + [] + [] + []))) + ,({ T17544.hs:22:1-30 } + (TyClD + (NoExtField) + (ClassDecl + (ExplicitBraces) + ({ <no location info> } + []) + ({ T17544.hs:22:7-8 } + (Unqual + {OccName: C5})) + (HsQTvs + (NoExtField) + [({ T17544.hs:22:10 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:22:10 } + (Unqual + {OccName: a}))))]) + (Prefix) + [] + [] + {Bag(Located (HsBind GhcPs)): + []} + [({ T17544.hs:22:20-28 } + (FamilyDecl + (NoExtField) + (DataFamily) + ({ T17544.hs:22:25-26 } + (Unqual + {OccName: D5})) + (HsQTvs + (NoExtField) + [({ T17544.hs:22:28 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:22:28 } + (Unqual + {OccName: a}))))]) + (Prefix) + ({ <no location info> } + (NoSig + (NoExtField))) + (Nothing)))] + [] + []))) + ,({ T17544.hs:(23,1)-(25,18) } + (InstD + (NoExtField) + (ClsInstD + (NoExtField) + (ClsInstDecl + (NoExtField) + (HsIB + (NoExtField) + ({ T17544.hs:23:10-15 } + (HsAppTy + (NoExtField) + ({ T17544.hs:23:10-11 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:23:10-11 } + (Unqual + {OccName: C5})))) + ({ T17544.hs:23:13-15 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:23:13-15 } + (Unqual + {OccName: Int}))))))) + {Bag(Located (HsBind GhcPs)): + []} + [] + [] + [({ T17544.hs:(24,3)-(25,18) } + (DataFamInstDecl + (HsIB + (NoExtField) + (FamEqn + (NoExtField) + ({ T17544.hs:24:8-9 } + (Unqual + {OccName: D5})) + (Nothing) + [(HsValArg + ({ T17544.hs:24:11-13 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:24:11-13 } + (Unqual + {OccName: Int})))))] + (Prefix) + (HsDataDefn + (NoExtField) + (DataType) + ({ <no location info> } + []) + (Nothing) + (Nothing) + [({ T17544.hs:25:5-18 } + (XConDecl + (ConDeclGADTPrefixPs + [({ T17544.hs:25:5-8 } + (Unqual + {OccName: MkD5}))] + (HsIB + (NoExtField) + ({ T17544.hs:25:13-18 } + (HsAppTy + (NoExtField) + ({ T17544.hs:25:13-14 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:25:13-14 } + (Unqual + {OccName: D5})))) + ({ T17544.hs:25:16-18 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:25:16-18 } + (Unqual + {OccName: Int}))))))) + (Nothing))))] + ({ <no location info> } + []))))))] + (Nothing))))) + ,({ T17544.hs:28:1-30 } + (TyClD + (NoExtField) + (ClassDecl + (ExplicitBraces) + ({ <no location info> } + []) + ({ T17544.hs:28:7-8 } + (Unqual + {OccName: C6})) + (HsQTvs + (NoExtField) + [({ T17544.hs:28:10 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:28:10 } + (Unqual + {OccName: a}))))]) + (Prefix) + [] + [] + {Bag(Located (HsBind GhcPs)): + []} + [({ T17544.hs:28:20-28 } + (FamilyDecl + (NoExtField) + (DataFamily) + ({ T17544.hs:28:25-26 } + (Unqual + {OccName: D6})) + (HsQTvs + (NoExtField) + [({ T17544.hs:28:28 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:28:28 } + (Unqual + {OccName: a}))))]) + (Prefix) + ({ <no location info> } + (NoSig + (NoExtField))) + (Nothing)))] + [] + []))) + ,({ T17544.hs:(29,1)-(31,18) } + (InstD + (NoExtField) + (ClsInstD + (NoExtField) + (ClsInstDecl + (NoExtField) + (HsIB + (NoExtField) + ({ T17544.hs:29:10-15 } + (HsAppTy + (NoExtField) + ({ T17544.hs:29:10-11 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:29:10-11 } + (Unqual + {OccName: C6})))) + ({ T17544.hs:29:13-15 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:29:13-15 } + (Unqual + {OccName: Int}))))))) + {Bag(Located (HsBind GhcPs)): + []} + [] + [] + [({ T17544.hs:(30,3)-(31,18) } + (DataFamInstDecl + (HsIB + (NoExtField) + (FamEqn + (NoExtField) + ({ T17544.hs:30:8-9 } + (Unqual + {OccName: D6})) + (Nothing) + [(HsValArg + ({ T17544.hs:30:11-13 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:30:11-13 } + (Unqual + {OccName: Int})))))] + (Prefix) + (HsDataDefn + (NoExtField) + (DataType) + ({ <no location info> } + []) + (Nothing) + (Nothing) + [({ T17544.hs:31:5-18 } + (XConDecl + (ConDeclGADTPrefixPs + [({ T17544.hs:31:5-8 } + (Unqual + {OccName: MkD6}))] + (HsIB + (NoExtField) + ({ T17544.hs:31:13-18 } + (HsAppTy + (NoExtField) + ({ T17544.hs:31:13-14 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:31:13-14 } + (Unqual + {OccName: D6})))) + ({ T17544.hs:31:16-18 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:31:16-18 } + (Unqual + {OccName: Int}))))))) + (Nothing))))] + ({ <no location info> } + []))))))] + (Nothing))))) + ,({ T17544.hs:34:1-30 } + (TyClD + (NoExtField) + (ClassDecl + (ExplicitBraces) + ({ <no location info> } + []) + ({ T17544.hs:34:7-8 } + (Unqual + {OccName: C7})) + (HsQTvs + (NoExtField) + [({ T17544.hs:34:10 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:34:10 } + (Unqual + {OccName: a}))))]) + (Prefix) + [] + [] + {Bag(Located (HsBind GhcPs)): + []} + [({ T17544.hs:34:20-28 } + (FamilyDecl + (NoExtField) + (DataFamily) + ({ T17544.hs:34:25-26 } + (Unqual + {OccName: D7})) + (HsQTvs + (NoExtField) + [({ T17544.hs:34:28 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:34:28 } + (Unqual + {OccName: a}))))]) + (Prefix) + ({ <no location info> } + (NoSig + (NoExtField))) + (Nothing)))] + [] + []))) + ,({ T17544.hs:(35,1)-(37,18) } + (InstD + (NoExtField) + (ClsInstD + (NoExtField) + (ClsInstDecl + (NoExtField) + (HsIB + (NoExtField) + ({ T17544.hs:35:10-15 } + (HsAppTy + (NoExtField) + ({ T17544.hs:35:10-11 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:35:10-11 } + (Unqual + {OccName: C7})))) + ({ T17544.hs:35:13-15 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:35:13-15 } + (Unqual + {OccName: Int}))))))) + {Bag(Located (HsBind GhcPs)): + []} + [] + [] + [({ T17544.hs:(36,3)-(37,18) } + (DataFamInstDecl + (HsIB + (NoExtField) + (FamEqn + (NoExtField) + ({ T17544.hs:36:8-9 } + (Unqual + {OccName: D7})) + (Nothing) + [(HsValArg + ({ T17544.hs:36:11-13 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:36:11-13 } + (Unqual + {OccName: Int})))))] + (Prefix) + (HsDataDefn + (NoExtField) + (DataType) + ({ <no location info> } + []) + (Nothing) + (Nothing) + [({ T17544.hs:37:5-18 } + (XConDecl + (ConDeclGADTPrefixPs + [({ T17544.hs:37:5-8 } + (Unqual + {OccName: MkD7}))] + (HsIB + (NoExtField) + ({ T17544.hs:37:13-18 } + (HsAppTy + (NoExtField) + ({ T17544.hs:37:13-14 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:37:13-14 } + (Unqual + {OccName: D7})))) + ({ T17544.hs:37:16-18 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:37:16-18 } + (Unqual + {OccName: Int}))))))) + (Nothing))))] + ({ <no location info> } + []))))))] + (Nothing))))) + ,({ T17544.hs:40:1-30 } + (TyClD + (NoExtField) + (ClassDecl + (ExplicitBraces) + ({ <no location info> } + []) + ({ T17544.hs:40:7-8 } + (Unqual + {OccName: C8})) + (HsQTvs + (NoExtField) + [({ T17544.hs:40:10 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:40:10 } + (Unqual + {OccName: a}))))]) + (Prefix) + [] + [] + {Bag(Located (HsBind GhcPs)): + []} + [({ T17544.hs:40:20-28 } + (FamilyDecl + (NoExtField) + (DataFamily) + ({ T17544.hs:40:25-26 } + (Unqual + {OccName: D8})) + (HsQTvs + (NoExtField) + [({ T17544.hs:40:28 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:40:28 } + (Unqual + {OccName: a}))))]) + (Prefix) + ({ <no location info> } + (NoSig + (NoExtField))) + (Nothing)))] + [] + []))) + ,({ T17544.hs:(41,1)-(43,18) } + (InstD + (NoExtField) + (ClsInstD + (NoExtField) + (ClsInstDecl + (NoExtField) + (HsIB + (NoExtField) + ({ T17544.hs:41:10-15 } + (HsAppTy + (NoExtField) + ({ T17544.hs:41:10-11 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:41:10-11 } + (Unqual + {OccName: C8})))) + ({ T17544.hs:41:13-15 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:41:13-15 } + (Unqual + {OccName: Int}))))))) + {Bag(Located (HsBind GhcPs)): + []} + [] + [] + [({ T17544.hs:(42,3)-(43,18) } + (DataFamInstDecl + (HsIB + (NoExtField) + (FamEqn + (NoExtField) + ({ T17544.hs:42:8-9 } + (Unqual + {OccName: D8})) + (Nothing) + [(HsValArg + ({ T17544.hs:42:11-13 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:42:11-13 } + (Unqual + {OccName: Int})))))] + (Prefix) + (HsDataDefn + (NoExtField) + (DataType) + ({ <no location info> } + []) + (Nothing) + (Nothing) + [({ T17544.hs:43:5-18 } + (XConDecl + (ConDeclGADTPrefixPs + [({ T17544.hs:43:5-8 } + (Unqual + {OccName: MkD8}))] + (HsIB + (NoExtField) + ({ T17544.hs:43:13-18 } + (HsAppTy + (NoExtField) + ({ T17544.hs:43:13-14 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:43:13-14 } + (Unqual + {OccName: D8})))) + ({ T17544.hs:43:16-18 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:43:16-18 } + (Unqual + {OccName: Int}))))))) + (Nothing))))] + ({ <no location info> } + []))))))] + (Nothing))))) + ,({ T17544.hs:46:1-30 } + (TyClD + (NoExtField) + (ClassDecl + (ExplicitBraces) + ({ <no location info> } + []) + ({ T17544.hs:46:7-8 } + (Unqual + {OccName: C9})) + (HsQTvs + (NoExtField) + [({ T17544.hs:46:10 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:46:10 } + (Unqual + {OccName: a}))))]) + (Prefix) + [] + [] + {Bag(Located (HsBind GhcPs)): + []} + [({ T17544.hs:46:20-28 } + (FamilyDecl + (NoExtField) + (DataFamily) + ({ T17544.hs:46:25-26 } + (Unqual + {OccName: D9})) + (HsQTvs + (NoExtField) + [({ T17544.hs:46:28 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:46:28 } + (Unqual + {OccName: a}))))]) + (Prefix) + ({ <no location info> } + (NoSig + (NoExtField))) + (Nothing)))] + [] + []))) + ,({ T17544.hs:(47,1)-(49,18) } + (InstD + (NoExtField) + (ClsInstD + (NoExtField) + (ClsInstDecl + (NoExtField) + (HsIB + (NoExtField) + ({ T17544.hs:47:10-15 } + (HsAppTy + (NoExtField) + ({ T17544.hs:47:10-11 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:47:10-11 } + (Unqual + {OccName: C9})))) + ({ T17544.hs:47:13-15 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:47:13-15 } + (Unqual + {OccName: Int}))))))) + {Bag(Located (HsBind GhcPs)): + []} + [] + [] + [({ T17544.hs:(48,3)-(49,18) } + (DataFamInstDecl + (HsIB + (NoExtField) + (FamEqn + (NoExtField) + ({ T17544.hs:48:8-9 } + (Unqual + {OccName: D9})) + (Nothing) + [(HsValArg + ({ T17544.hs:48:11-13 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:48:11-13 } + (Unqual + {OccName: Int})))))] + (Prefix) + (HsDataDefn + (NoExtField) + (DataType) + ({ <no location info> } + []) + (Nothing) + (Nothing) + [({ T17544.hs:49:5-18 } + (XConDecl + (ConDeclGADTPrefixPs + [({ T17544.hs:49:5-8 } + (Unqual + {OccName: MkD9}))] + (HsIB + (NoExtField) + ({ T17544.hs:49:13-18 } + (HsAppTy + (NoExtField) + ({ T17544.hs:49:13-14 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:49:13-14 } + (Unqual + {OccName: D9})))) + ({ T17544.hs:49:16-18 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:49:16-18 } + (Unqual + {OccName: Int}))))))) + (Nothing))))] + ({ <no location info> } + []))))))] + (Nothing))))) + ,({ T17544.hs:52:1-32 } + (TyClD + (NoExtField) + (ClassDecl + (ExplicitBraces) + ({ <no location info> } + []) + ({ T17544.hs:52:7-9 } + (Unqual + {OccName: C10})) + (HsQTvs + (NoExtField) + [({ T17544.hs:52:11 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:52:11 } + (Unqual + {OccName: a}))))]) + (Prefix) + [] + [] + {Bag(Located (HsBind GhcPs)): + []} + [({ T17544.hs:52:21-30 } + (FamilyDecl + (NoExtField) + (DataFamily) + ({ T17544.hs:52:26-28 } + (Unqual + {OccName: D10})) + (HsQTvs + (NoExtField) + [({ T17544.hs:52:30 } + (UserTyVar + (NoExtField) + (()) + ({ T17544.hs:52:30 } + (Unqual + {OccName: a}))))]) + (Prefix) + ({ <no location info> } + (NoSig + (NoExtField))) + (Nothing)))] + [] + []))) + ,({ T17544.hs:(53,1)-(55,20) } + (InstD + (NoExtField) + (ClsInstD + (NoExtField) + (ClsInstDecl + (NoExtField) + (HsIB + (NoExtField) + ({ T17544.hs:53:10-16 } + (HsAppTy + (NoExtField) + ({ T17544.hs:53:10-12 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:53:10-12 } + (Unqual + {OccName: C10})))) + ({ T17544.hs:53:14-16 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:53:14-16 } + (Unqual + {OccName: Int}))))))) + {Bag(Located (HsBind GhcPs)): + []} + [] + [] + [({ T17544.hs:(54,3)-(55,20) } + (DataFamInstDecl + (HsIB + (NoExtField) + (FamEqn + (NoExtField) + ({ T17544.hs:54:8-10 } + (Unqual + {OccName: D10})) + (Nothing) + [(HsValArg + ({ T17544.hs:54:12-14 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:54:12-14 } + (Unqual + {OccName: Int})))))] + (Prefix) + (HsDataDefn + (NoExtField) + (DataType) + ({ <no location info> } + []) + (Nothing) + (Nothing) + [({ T17544.hs:55:5-20 } + (XConDecl + (ConDeclGADTPrefixPs + [({ T17544.hs:55:5-9 } + (Unqual + {OccName: MkD10}))] + (HsIB + (NoExtField) + ({ T17544.hs:55:14-20 } + (HsAppTy + (NoExtField) + ({ T17544.hs:55:14-16 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:55:14-16 } + (Unqual + {OccName: D10})))) + ({ T17544.hs:55:18-20 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544.hs:55:18-20 } + (Unqual + {OccName: Int}))))))) + (Nothing))))] + ({ <no location info> } + []))))))] + (Nothing))))) + ,({ T17544.hs:56:1-38 } + (DocD + (NoExtField) + (DocCommentPrev + (HsDocString + " comment on class instance C10 Int"))))] + (Nothing) + (Nothing))) + + + +T17544.hs:19:1: warning: [-Winvalid-haddock] + A Haddock comment cannot appear in this position and will be ignored. + +T17544.hs:26:6: warning: [-Winvalid-haddock] + A Haddock comment cannot appear in this position and will be ignored. + +T17544.hs:32:5: warning: [-Winvalid-haddock] + A Haddock comment cannot appear in this position and will be ignored. + +T17544.hs:38:4: warning: [-Winvalid-haddock] + A Haddock comment cannot appear in this position and will be ignored. + +T17544.hs:44:3: warning: [-Winvalid-haddock] + A Haddock comment cannot appear in this position and will be ignored. + +T17544.hs:50:2: warning: [-Winvalid-haddock] + A Haddock comment cannot appear in this position and will be ignored. diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs new file mode 100644 index 0000000000..4acf2af68d --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS -haddock -ddump-parsed-ast #-} + +-- Haddock comments in this test case should all be rejected, but they are not. +-- +-- This is a known issue. Users should avoid writing comments in such +-- positions, as a future fix will disallow them. +-- +-- See Note [Register keyword location] in GHC.Parser.PostProcess.Haddock + +module + -- | Bad comment for the module + T17544_kw where + +data Foo -- | Bad comment for MkFoo + where MkFoo :: Foo + +newtype Bar -- | Bad comment for MkBar + where MkBar :: () -> Bar + +class Cls a + -- | Bad comment for clsmethod + where + clsmethod :: a diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr new file mode 100644 index 0000000000..9d45b6a86d --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr @@ -0,0 +1,154 @@ + +==================== Parser AST ==================== + +({ T17544_kw.hs:1:1 } + (HsModule + (VirtualBraces + (1)) + (Just + ({ T17544_kw.hs:13:3-11 } + {ModuleName: T17544_kw})) + (Nothing) + [] + [({ T17544_kw.hs:(15,1)-(16,20) } + (TyClD + (NoExtField) + (DataDecl + (NoExtField) + ({ T17544_kw.hs:15:6-8 } + (Unqual + {OccName: Foo})) + (HsQTvs + (NoExtField) + []) + (Prefix) + (HsDataDefn + (NoExtField) + (DataType) + ({ <no location info> } + []) + (Nothing) + (Nothing) + [({ T17544_kw.hs:16:9-20 } + (XConDecl + (ConDeclGADTPrefixPs + [({ T17544_kw.hs:16:9-13 } + (Unqual + {OccName: MkFoo}))] + (HsIB + (NoExtField) + ({ T17544_kw.hs:16:18-20 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544_kw.hs:16:18-20 } + (Unqual + {OccName: Foo}))))) + (Just + ({ T17544_kw.hs:15:10-35 } + (HsDocString + " Bad comment for MkFoo"))))))] + ({ <no location info> } + []))))) + ,({ T17544_kw.hs:(18,1)-(19,26) } + (TyClD + (NoExtField) + (DataDecl + (NoExtField) + ({ T17544_kw.hs:18:9-11 } + (Unqual + {OccName: Bar})) + (HsQTvs + (NoExtField) + []) + (Prefix) + (HsDataDefn + (NoExtField) + (NewType) + ({ <no location info> } + []) + (Nothing) + (Nothing) + [({ T17544_kw.hs:19:9-26 } + (XConDecl + (ConDeclGADTPrefixPs + [({ T17544_kw.hs:19:9-13 } + (Unqual + {OccName: MkBar}))] + (HsIB + (NoExtField) + ({ T17544_kw.hs:19:18-26 } + (HsFunTy + (NoExtField) + (HsUnrestrictedArrow) + ({ T17544_kw.hs:19:18-19 } + (HsTupleTy + (NoExtField) + (HsBoxedOrConstraintTuple) + [])) + ({ T17544_kw.hs:19:24-26 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544_kw.hs:19:24-26 } + (Unqual + {OccName: Bar}))))))) + (Just + ({ T17544_kw.hs:18:13-38 } + (HsDocString + " Bad comment for MkBar"))))))] + ({ <no location info> } + []))))) + ,({ T17544_kw.hs:(21,1)-(24,18) } + (TyClD + (NoExtField) + (ClassDecl + (VirtualBraces + (5)) + ({ <no location info> } + []) + ({ T17544_kw.hs:21:7-9 } + (Unqual + {OccName: Cls})) + (HsQTvs + (NoExtField) + [({ T17544_kw.hs:21:11 } + (UserTyVar + (NoExtField) + (()) + ({ T17544_kw.hs:21:11 } + (Unqual + {OccName: a}))))]) + (Prefix) + [] + [({ T17544_kw.hs:24:5-18 } + (ClassOpSig + (NoExtField) + (False) + [({ T17544_kw.hs:24:5-13 } + (Unqual + {OccName: clsmethod}))] + (HsIB + (NoExtField) + ({ T17544_kw.hs:24:18 } + (HsTyVar + (NoExtField) + (NotPromoted) + ({ T17544_kw.hs:24:18 } + (Unqual + {OccName: a})))))))] + {Bag(Located (HsBind GhcPs)): + []} + [] + [] + [({ T17544_kw.hs:22:5-34 } + (DocCommentNext + (HsDocString + " Bad comment for clsmethod")))])))] + (Nothing) + (Just + ({ T17544_kw.hs:12:3-33 } + (HsDocString + " Bad comment for the module"))))) + + diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T8944.hs b/testsuite/tests/haddock/should_compile_flag_haddock/T8944.hs new file mode 100644 index 0000000000..93ce9de99b --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T8944.hs @@ -0,0 +1,10 @@ +module T8944 where + +import Data.Maybe () +-- * whatever +import Data.Functor () + +data F = F () -- ^ Comment for the first argument + () + + diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T8944.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T8944.stderr new file mode 100644 index 0000000000..6a7e12e763 --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T8944.stderr @@ -0,0 +1,11 @@ + +==================== Parser ==================== +module T8944 where +import Data.Maybe () +import Data.Functor () +data F = F () " Comment for the first argument" () + + + +T8944.hs:4:1: warning: [-Winvalid-haddock] + A Haddock comment cannot appear in this position and will be ignored. diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/all.T b/testsuite/tests/haddock/should_compile_flag_haddock/all.T index c7b9d91c25..b35af797ce 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/all.T +++ b/testsuite/tests/haddock/should_compile_flag_haddock/all.T @@ -7,53 +7,58 @@ # When adding a new test here, think about adding it to the # should_compile_noflag_haddock directory as well. -test('haddockA001', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA002', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA003', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA004', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA005', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA006', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA007', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA008', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA009', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA010', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA011', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA012', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA013', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA014', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA015', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA016', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA017', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA018', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA019', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA020', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA021', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA022', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA023', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA024', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA025', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA026', normal, compile, ['-haddock -ddump-parsed -XRankNTypes']) -test('haddockA027', normal, compile, ['-haddock -ddump-parsed -XRankNTypes']) -test('haddockA028', normal, compile, ['-haddock -ddump-parsed -XTypeOperators']) -test('haddockA029', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA030', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA031', normal, compile, ['-haddock -ddump-parsed -XExistentialQuantification']) -test('haddockA032', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA035', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA036', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA037', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA038', normal, compile, ['-haddock -ddump-parsed']) +test('haddockA001', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA002', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA003', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA004', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA005', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA006', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA007', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA008', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA009', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA010', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA011', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA012', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA013', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA014', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA015', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA016', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA017', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA018', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA019', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA020', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA021', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA022', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA023', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA024', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA025', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA026', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed -XRankNTypes']) +test('haddockA027', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed -XRankNTypes']) +test('haddockA028', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed -XTypeOperators']) +test('haddockA029', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA030', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA031', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed -XExistentialQuantification']) +test('haddockA032', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA035', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA036', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA037', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA038', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) # The tests below this line are not duplicated in # should_compile_noflag_haddock. -test('haddockA033', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA034', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA039', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA040', normal, compile, ['-haddock -ddump-parsed']) -test('haddockA041', [extra_files(['IncludeMe.hs'])], compile, ['-haddock -ddump-parsed']) -test('T10398', normal, compile, ['-haddock -ddump-parsed']) -test('T11768', normal, compile, ['-haddock -ddump-parsed']) -test('T15206', normal, compile, ['-haddock -ddump-parsed']) -test('T16585', normal, compile, ['-haddock -ddump-parsed']) -test('T17561', expect_broken(17561), compile, ['-haddock -ddump-parsed']) +test('haddockA033', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA034', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA039', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA040', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('haddockA041', [extra_files(['IncludeMe.hs'])], compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('T10398', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('T11768', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('T15206', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('T16585', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('T17561', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('T17544', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed-ast']) +test('T17544_kw', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed-ast']) +test('haddockExtraDocs', normal, compile, ['-haddock -Winvalid-haddock']) +test('haddockTySyn', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) +test('T8944', normal, compile, ['-haddock -Winvalid-haddock -ddump-parsed']) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA022.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA022.stderr index 6e6c5c6730..010ec9c069 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA022.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA022.stderr @@ -1,9 +1,19 @@ ==================== Parser ==================== -main = print (test :: Int) - where - test = 0 - test2 = 1 - test3 = 2 +main + = print (test :: Int) + where + test = 0 + test2 = 1 + test3 = 2 + +haddockA022.hs:4:5: warning: [-Winvalid-haddock] + A Haddock comment cannot appear in this position and will be ignored. + +haddockA022.hs:6:5: warning: [-Winvalid-haddock] + A Haddock comment cannot appear in this position and will be ignored. + +haddockA022.hs:10:5: warning: [-Winvalid-haddock] + A Haddock comment cannot appear in this position and will be ignored. diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr index e09cfa2187..81b172ed80 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr @@ -2,9 +2,13 @@ ==================== Parser ==================== module ShouldCompile where data A - = " comment for A " A | + = " A comment that documents the first constructor" A | " comment for B " B | " comment for C " C | D + +haddockA030.hs:7:5: warning: [-Winvalid-haddock] + Multiple Haddock comments for a single entity are not allowed. + The extraneous comment will be ignored. diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA033.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA033.stderr index c1760c11fe..e3df0ec16f 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA033.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA033.stderr @@ -9,3 +9,9 @@ f 3 = 6 <document comment> + +haddockA033.hs:5:1: warning: [-Winvalid-haddock] + A Haddock comment cannot appear in this position and will be ignored. + +haddockA033.hs:7:1: warning: [-Winvalid-haddock] + A Haddock comment cannot appear in this position and will be ignored. diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA041.hs b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA041.hs index fe9f7a24c4..3ba2c48fd9 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA041.hs +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA041.hs @@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-} - -- | Module header documentation module Comments_and_CPP_include where - #include "IncludeMe.hs" diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockExtraDocs.hs b/testsuite/tests/haddock/should_compile_flag_haddock/haddockExtraDocs.hs new file mode 100644 index 0000000000..dc91ab3126 --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockExtraDocs.hs @@ -0,0 +1,25 @@ +module HaddockExtraDocs where + +data SomeField = SomeField + +data T1 = + MkT1 + -- | Comment on SomeField + SomeField + -- ^ Another comment on SomeField? (rejected) + +data T2 = + MkT2 { + -- | Comment on SomeField + someField :: SomeField + } -- ^ Another comment on SomeField? (rejected) + +data T3 = + -- | Comment on MkT3 + MkT3 + -- ^ Another comment on MkT3? (rejected) + +data T4 = + -- | Comment on MkT4 + MkT4 {} + -- ^ Another comment on MkT4? (rejected) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockExtraDocs.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockExtraDocs.stderr new file mode 100644 index 0000000000..b1e6cb5565 --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockExtraDocs.stderr @@ -0,0 +1,16 @@ + +haddockExtraDocs.hs:9:5: warning: [-Winvalid-haddock] + Multiple Haddock comments for a single entity are not allowed. + The extraneous comment will be ignored. + +haddockExtraDocs.hs:15:5: warning: [-Winvalid-haddock] + Multiple Haddock comments for a single entity are not allowed. + The extraneous comment will be ignored. + +haddockExtraDocs.hs:20:3: warning: [-Winvalid-haddock] + Multiple Haddock comments for a single entity are not allowed. + The extraneous comment will be ignored. + +haddockExtraDocs.hs:25:3: warning: [-Winvalid-haddock] + Multiple Haddock comments for a single entity are not allowed. + The extraneous comment will be ignored. diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockTySyn.hs b/testsuite/tests/haddock/should_compile_flag_haddock/haddockTySyn.hs new file mode 100644 index 0000000000..d8597e003a --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockTySyn.hs @@ -0,0 +1,3 @@ +module HaddockTySyn where + +type T = Int -- ^ Comment on type synonym RHS diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockTySyn.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockTySyn.stderr new file mode 100644 index 0000000000..cc675fe568 --- /dev/null +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockTySyn.stderr @@ -0,0 +1,6 @@ + +==================== Parser ==================== +module HaddockTySyn where +type T = Int " Comment on type synonym RHS" + + diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index b14b69dc04..5a6c569ad3 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -3,6 +3,8 @@ ({ DumpParsedAst.hs:1:1 } (HsModule + (VirtualBraces + (1)) (Just ({ DumpParsedAst.hs:4:8-20 } {ModuleName: DumpParsedAst})) diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index 689cc4187f..c5976593d3 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -3,6 +3,8 @@ ({ KindSigs.hs:1:1 } (HsModule + (VirtualBraces + (1)) (Just ({ KindSigs.hs:6:8-15 } {ModuleName: KindSigs})) diff --git a/testsuite/tests/parser/should_compile/T15323.stderr b/testsuite/tests/parser/should_compile/T15323.stderr index fd48dbf203..7b8436f2cb 100644 --- a/testsuite/tests/parser/should_compile/T15323.stderr +++ b/testsuite/tests/parser/should_compile/T15323.stderr @@ -3,6 +3,8 @@ ({ T15323.hs:1:1 } (HsModule + (VirtualBraces + (1)) (Just ({ T15323.hs:3:8-13 } {ModuleName: T15323})) diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs index b222b726fb..9bc776d4d5 100644 --- a/utils/check-ppr/Main.hs +++ b/utils/check-ppr/Main.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} import Data.List +import Data.Data import GHC.Types.SrcLoc import GHC hiding (moduleName) import GHC.Hs.Dump @@ -30,7 +34,8 @@ testOneFile libdir fileName = do p <- parseOneFile libdir fileName let origAst = showSDoc unsafeGlobalDynFlags - $ showAstData BlankSrcSpan (pm_parsed_source p) + $ showAstData BlankSrcSpan + $ eraseLayoutInfo (pm_parsed_source p) pped = pragmas ++ "\n" ++ pp (pm_parsed_source p) anns = pm_annotations p pragmas = getPragmas anns @@ -46,7 +51,8 @@ testOneFile libdir fileName = do let newAstStr :: String newAstStr = showSDoc unsafeGlobalDynFlags - $ showAstData BlankSrcSpan (pm_parsed_source p') + $ showAstData BlankSrcSpan + $ eraseLayoutInfo (pm_parsed_source p') writeFile newAstFile newAstStr if origAst == newAstStr @@ -98,4 +104,22 @@ getPragmas anns = pragmaStr pp :: (Outputable a) => a -> String pp a = showPpr unsafeGlobalDynFlags a +eraseLayoutInfo :: ParsedSource -> ParsedSource +eraseLayoutInfo = everywhere go + where + go :: forall a. Typeable a => a -> a + go x = + case eqT @a @LayoutInfo of + Nothing -> x + Just Refl -> NoLayoutInfo + +-- --------------------------------------------------------------------- +-- Copied from syb for the test + +everywhere :: (forall a. Data a => a -> a) + -> (forall a. Data a => a -> a) +everywhere f = go + where + go :: forall a. Data a => a -> a + go = f . gmapT go |