diff options
Diffstat (limited to 'compiler/GHC/Parser')
| -rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 17 | ||||
| -rw-r--r-- | compiler/GHC/Parser/PostProcess/Haddock.hs | 28 |
2 files changed, 25 insertions, 20 deletions
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 568f5df5e6..74a44fa384 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -720,7 +720,8 @@ mkConDeclH98 ann name mb_forall mb_cxt args -- * This splits up the constructor type into its quantified type variables (if -- provided), context (if provided), argument types, and result type, and -- records whether this is a prefix or record GADT constructor. See --- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. +-- @Note [GADT abstract syntax]@ in "Language.Haskell.Syntax.Decls" for more +-- details. mkGadtDecl :: SrcSpan -> [LocatedN RdrName] -> LHsSigType GhcPs @@ -730,7 +731,7 @@ mkGadtDecl loc names ty annsIn = do cs <- getCommentsFor loc let l = noAnnSrcSpan loc - (args, res_ty, annsa, csa) <- + (body, annsa, csa) <- case body_ty of L ll (HsFunTy af hsArr (L loc' (HsRecTy an rf)) res_ty) -> do let an' = addCommentsToEpAnn (locA loc') an (comments af) @@ -740,22 +741,20 @@ mkGadtDecl loc names ty annsIn = do (PsErrIllegalGadtRecordMultiplicity hsArr) return noHsUniTok - return ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf) arr, res_ty + return ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf) arr res_ty , [], epAnnComments (ann ll)) _ -> do - let (anns, cs, arg_types, res_type) = splitHsFunType body_ty - return (PrefixConGADT arg_types, res_type, anns, cs) + let (anns, cs, prefix_body) = splitLHsPrefixGadtSigBody body_ty + return (PrefixConGADT prefix_body, anns, cs) - let an = case outer_bndrs of - _ -> EpAnn (spanAsAnchor loc) (annsIn ++ annsa) (cs Semi.<> csa) + let an = EpAnn (spanAsAnchor loc) (annsIn ++ annsa) (cs Semi.<> csa) pure $ L l ConDeclGADT { con_g_ext = an , con_names = names , con_bndrs = L (getLoc ty) outer_bndrs , con_mb_cxt = mcxt - , con_g_args = args - , con_res_ty = res_ty + , con_body = body , con_doc = Nothing } where (outer_bndrs, mcxt, body_ty) = splitLHsGadtTy ty diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 271d9db30f..2ce0dd5274 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -696,22 +696,14 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where addHaddock (L l_con_decl con_decl) = extendHdkA (locA l_con_decl) $ case con_decl of - ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do + ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, con_body } -> do -- discardHasInnerDocs is ok because we don't need this info for GADTs. con_doc' <- discardHasInnerDocs $ getConDoc (getLocA (head con_names)) - con_g_args' <- - case con_g_args of - PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts - RecConGADT (L l_rec flds) arr -> do - -- discardHasInnerDocs is ok because we don't need this info for GADTs. - flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds - pure $ RecConGADT (L l_rec flds') arr - con_res_ty' <- addHaddock con_res_ty + con_body' <- addHaddock con_body pure $ L l_con_decl $ ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, con_doc = lexLHsDocString <$> con_doc', - con_g_args = con_g_args', - con_res_ty = con_res_ty' } + con_body = con_body' } ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } -> addConTrailingDoc (srcSpanEnd $ locA l_con_decl) $ case con_args of @@ -738,6 +730,20 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where con_doc = lexLHsDocString <$> con_doc', con_args = RecCon (L l_rec flds') } +instance HasHaddock (ConGadtSigBody GhcPs) where + addHaddock (PrefixConGADT body) = PrefixConGADT <$> addHaddock body + addHaddock (RecConGADT (L l_rec flds) arr res_ty) = do + -- discardHasInnerDocs is ok because we don't need this info for GADTs. + flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds + res_ty' <- addHaddock res_ty + pure $ RecConGADT (L l_rec flds') arr res_ty' + +instance HasHaddock (PrefixConGadtSigBody GhcPs) where + addHaddock (PCGSAnonArg arg_ty body) = + PCGSAnonArg <$> addHaddock arg_ty <*> addHaddock body + addHaddock (PCGSRes res_ty) = + PCGSRes <$> addHaddock res_ty + -- Keep track of documentation comments on the data constructor or any of its -- fields. -- |