[Git][ghc/ghc][wip/T18462] Add doc field to CFS
Sjoerd Visscher (@trac-sjoerd_visscher)
gitlab at gitlab.haskell.org
Tue Jan 21 18:26:45 UTC 2025
Sjoerd Visscher pushed to branch wip/T18462 at Glasgow Haskell Compiler / GHC
Commits:
8e23f4d9 by Sjoerd Visscher at 2025-01-21T19:26:26+01:00
Add doc field to CFS
- - - - -
17 changed files:
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Type.hs
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
Changes:
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -61,7 +61,7 @@ module GHC.Hs.Type (
HsConDetails(..), noTypeArgs,
HsConFieldSpec(..), pprHsConFieldSpecWith, pprHsConFieldSpecNoMult,
- hsPlainTypeField, hsConFieldSpecToHsTypes, mkConFieldSpec,
+ hsPlainTypeField, mkConFieldSpec,
FieldOcc(..), LFieldOcc, mkFieldOcc,
fieldOccRdrName, fieldOccLRdrName,
@@ -570,7 +570,7 @@ type instance XXConDeclField (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
=> Outputable (ConDeclField (GhcPass p)) where
- ppr (ConDeclField _ fld_n cfs _) = ppr_names fld_n <+> pprHsConFieldSpecWith ppr_mult cfs
+ ppr (ConDeclField _ fld_n cfs) = pprMaybeWithDoc (cfs_doc cfs) (ppr_names fld_n <+> pprHsConFieldSpecWith ppr_mult cfs { cfs_doc = Nothing })
where
ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc
ppr_names [n] = pprPrefixOcc n
@@ -1286,24 +1286,22 @@ instance (Outputable tyarg, Outputable arg, Outputable rec)
ppr (RecCon rec) = text "RecCon:" <+> ppr rec
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
-pprHsConFieldSpecWith :: (OutputableBndrId p) => (HsMultAnnOn on (LHsType (GhcPass p)) (GhcPass p) -> SDoc -> SDoc) -> HsConFieldSpec on (GhcPass p) -> SDoc
-pprHsConFieldSpecWith ppr_mult (CFS _ prag mark mult (L _ (HsDocTy _ ty doc))) = ppr_mult mult (pprWithDoc doc $ ppr prag <+> ppr mark <> ppr ty)
-pprHsConFieldSpecWith ppr_mult (CFS _ prag mark mult ty) = ppr_mult mult (ppr prag <+> ppr mark <> ppr ty)
+pprHsConFieldSpecWith :: (OutputableBndrId p)
+ => (HsMultAnnOn on (LHsType (GhcPass p)) (GhcPass p) -> SDoc -> SDoc)
+ -> HsConFieldSpec on (GhcPass p) -> SDoc
+pprHsConFieldSpecWith ppr_mult (CFS _ prag mark mult ty doc) =
+ pprMaybeWithDoc doc (ppr_mult mult (ppr prag <+> ppr mark <> ppr ty))
pprHsConFieldSpecNoMult :: (OutputableBndrId p) => HsConFieldSpec on (GhcPass p) -> SDoc
pprHsConFieldSpecNoMult = pprHsConFieldSpecWith (\_ d -> d)
-hsConFieldSpecToHsTypes :: HsConFieldSpec on GhcRn -> [LHsType GhcRn]
-hsConFieldSpecToHsTypes (CFS _ _ _ arr t) = [multAnnToHsType arr, t]
-
hsPlainTypeField :: LHsType GhcPs -> HsConFieldSpec OnArrow GhcPs
hsPlainTypeField = mkConFieldSpec (HsLinearAnn noAnn)
mkConFieldSpec :: HsMultAnnOn on (LHsType GhcPs) GhcPs -> LHsType GhcPs -> HsConFieldSpec on GhcPs
-mkConFieldSpec mult (L l (HsDocTy x ty lds)) = case mkConFieldSpec mult ty of
- CFS ann unp str mult' t -> CFS ann unp str mult' (L l (HsDocTy x t lds))
-mkConFieldSpec mult (L _ (XHsType (HsBangTy ann (HsBang unp str) t))) = CFS ann unp str mult t
-mkConFieldSpec mult t = CFS noAnn NoSrcUnpack NoSrcStrict mult t
+mkConFieldSpec mult (L _ (HsDocTy _ ty lds)) = (mkConFieldSpec mult ty) { cfs_doc = Just lds }
+mkConFieldSpec mult (L _ (XHsType (HsBangTy ann (HsBang unp str) t))) = CFS ann unp str mult t Nothing
+mkConFieldSpec mult t = CFS noAnn NoSrcUnpack NoSrcStrict mult t Nothing
instance Outputable (XRecGhc (IdGhcP p)) =>
Outputable (FieldOcc (GhcPass p)) where
@@ -1379,11 +1377,7 @@ pprLHsContextAlways (L _ ctxt)
pprConDeclFields :: forall p. OutputableBndrId p
=> [LConDeclField (GhcPass p)] -> SDoc
-pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
- where
- ppr_fld :: LConDeclField (GhcPass p) -> SDoc
- ppr_fld (L _ (cdf at ConDeclField { cd_fld_doc = doc }))
- = pprMaybeWithDoc doc (ppr cdf)
+pprConDeclFields fields = braces (sep (punctuate comma (map ppr fields)))
-- Printing works more-or-less as for Types
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -399,7 +399,7 @@ subordinates env instMap decl = case decl of
| c <- toList cons, cname <- getConNames c ]
fields = [ (unLoc $ foLabel n, maybeToList $ fmap unLoc doc, IM.empty)
| Just flds <- toList $ fmap getRecConArgs_maybe cons
- , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
+ , (L _ (ConDeclField _ ns (CFS { cfs_doc = doc }))) <- (unLoc flds)
, (L _ n) <- ns ]
derivs = [ (instName, [unLoc doc], IM.empty)
| (l, doc) <- concatMap (extract_deriv_clause_tys .
@@ -430,20 +430,23 @@ conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =
h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap (HsDoc GhcRn)
h98ConArgDocs con_args = case con_args of
- PrefixCon _ args -> con_arg_docs 0 $ map (unLoc . cfs_type) args
- InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (cfs_type arg1)
- , unLoc (cfs_type arg2) ]
+ PrefixCon _ args -> con_arg_docs 0 $ map cfs_doc args
+ InfixCon arg1 arg2 -> con_arg_docs 0 [ cfs_doc arg1, cfs_doc arg2 ]
RecCon _ -> IM.empty
gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap (HsDoc GhcRn)
gadtConArgDocs con_args res_ty = case con_args of
- PrefixConGADT _ args -> con_arg_docs 0 $ map (unLoc . cfs_type) args ++ [res_ty]
- RecConGADT _ _ -> con_arg_docs 1 [res_ty]
+ PrefixConGADT _ args -> con_arg_docs 0 $ map cfs_doc args ++ [res_doc]
+ RecConGADT _ _ -> con_arg_docs 1 [res_doc]
+ where
+ res_doc = case res_ty of
+ HsDocTy _ _ lds -> Just lds
+ _ -> Nothing
-con_arg_docs :: Int -> [HsType GhcRn] -> IntMap (HsDoc GhcRn)
+con_arg_docs :: Int -> [Maybe (LHsDoc GhcRn)] -> IntMap (HsDoc GhcRn)
con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..]
where
- f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
+ f n (Just lds) = Just (n, unLoc lds)
f _ _ = Nothing
isValD :: HsDecl a -> Bool
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -921,7 +921,7 @@ repSrcStrictness SrcStrict = rep2 sourceStrictName []
repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
repConFieldSpec :: HsConFieldSpec on GhcRn -> MetaM (Core (M TH.BangType))
-repConFieldSpec (CFS _ su ss _ ty') = do
+repConFieldSpec (CFS _ su ss _ ty' _) = do
MkC u <- repSrcUnpackedness su
MkC s <- repSrcStrictness ss
MkC b <- rep2 bangName [u, s]
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1796,7 +1796,11 @@ instance ToHie (LocatedL [LocatedA (ConDeclField GhcRn)]) where
]
instance ToHie (HsConFieldSpec on GhcRn) where
- toHie (CFS _ _ _ w t) = concatM [toHie (multAnnToHsType w), toHie t]
+ toHie (CFS _ _ _ w t doc) = concatM
+ [ toHie (multAnnToHsType w)
+ , toHie t
+ , toHie doc
+ ]
instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsSigType GhcRn)))) where
toHie (TS sc (HsWC names a)) = concatM $
@@ -1993,10 +1997,9 @@ instance HiePass p => ToHie (LocatedC [LocatedA (HsExpr (GhcPass p))]) where
instance ToHie (LocatedA (ConDeclField GhcRn)) where
toHie (L span field) = concatM $ makeNode field (locA span) : case field of
- ConDeclField _ fields typ doc ->
+ ConDeclField _ fields typ ->
[ toHie $ map (RFC RecFieldDecl (getRealSpan $ getHasLoc $ cfs_type typ)) fields
, toHie typ
- , toHie doc
]
instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2598,15 +2598,13 @@ fielddecl :: { LConDeclField GhcPs }
(ConDeclField noExtField
(reverse (map (\ln@(L l n)
-> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1)))
- (mkConFieldSpec (HsUnannotated HsUnannOne (epUniTok $2)) $3)
- Nothing))}
+ (mkConFieldSpec (HsUnannotated HsUnannOne (epUniTok $2)) $3)))}
| sig_vars PREFIX_PERCENT atype '::' ctype
{% amsA' (L (comb4 $1 $2 $3 $5)
(ConDeclField noExtField
(reverse (map (\ln@(L l n)
-> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1)))
- (mkMultField (epTok $2) $3 (epUniTok $4) $5)
- Nothing))}
+ (mkMultField (epTok $2) $3 (epUniTok $4) $5)))}
-- Reversed!
maybe_derivings :: { Located (HsDeriving GhcPs) }
=====================================
compiler/GHC/Parser/PostProcess/Haddock.hs
=====================================
@@ -215,9 +215,8 @@ collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } =
-- 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.
+-- 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.
--
-- See Note [Adding Haddock comments to the syntax tree].
class HasHaddock a where
@@ -711,7 +710,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where
case con_g_args of
PrefixConGADT x ts -> PrefixConGADT x <$> addHaddock ts
RecConGADT arr (L l_rec flds) -> do
- flds' <- traverse addHaddockConDeclField flds
+ flds' <- traverse addHaddock flds
pure $ RecConGADT arr (L l_rec flds')
con_res_ty' <- addHaddock con_res_ty
pure $ L l_con_decl $
@@ -735,22 +734,22 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where
case con_args of
PrefixCon _ ts -> do
con_doc' <- getConDoc (getLocA con_name)
- ts' <- traverse addHaddockConDeclFieldTy ts
+ ts' <- traverse addHaddock ts
pure $ L l_con_decl $
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
con_doc = lexLHsDocString <$> con_doc',
con_args = PrefixCon noTypeArgs ts' }
InfixCon t1 t2 -> do
- t1' <- addHaddockConDeclFieldTy t1
+ t1' <- addHaddock t1
con_doc' <- getConDoc (getLocA con_name)
- t2' <- addHaddockConDeclFieldTy t2
+ t2' <- addHaddock t2
pure $ L l_con_decl $
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
con_doc = lexLHsDocString <$> con_doc',
con_args = InfixCon t1' t2' }
RecCon (L l_rec flds) -> do
con_doc' <- getConDoc (getLocA con_name)
- flds' <- traverse addHaddockConDeclField flds
+ flds' <- traverse addHaddock flds
pure $ L l_con_decl $
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
con_doc = lexLHsDocString <$> con_doc',
@@ -785,25 +784,11 @@ getConDoc
-> HdkA (Maybe (Located HsDocString))
getConDoc l = extendHdkA l $ liftHdkA $ getPrevNextDoc l
--- Add documentation comment to a data constructor field.
--- Used for PrefixCon and InfixCon.
-addHaddockConDeclFieldTy
- :: HsConFieldSpec on GhcPs
- -> HdkA (HsConFieldSpec on GhcPs)
-addHaddockConDeclFieldTy (CFS ann unpack strict mult (L l t)) =
- extendHdkA (locA l) $ liftHdkA $ do
- mDoc <- getPrevNextDoc (locA l)
- return (CFS ann unpack strict mult (mkLHsDocTy (L l t) mDoc))
-
--- Add documentation comment to a data constructor field.
--- Used for RecCon.
-addHaddockConDeclField
- :: LConDeclField GhcPs
- -> HdkA (LConDeclField GhcPs)
-addHaddockConDeclField (L l_fld fld) =
- extendHdkA (locA l_fld) $ liftHdkA $ do
- cd_fld_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld)
- return (L l_fld (fld { cd_fld_doc }))
+instance HasHaddock (LocatedA (ConDeclField GhcPs)) where
+ addHaddock (L l_fld (ConDeclField ext nms cfs)) =
+ extendHdkA (locA l_fld) $ liftHdkA $ do
+ cfs_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld)
+ return $ L l_fld (ConDeclField ext nms (cfs { cfs_doc }))
{- Note [Leading and trailing comments on H98 constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -907,7 +892,11 @@ We implement this in two steps:
-}
instance HasHaddock (HsConFieldSpec on GhcPs) where
- addHaddock (CFS ann unp str mult a) = CFS ann unp str mult <$> addHaddock a
+ addHaddock cfs = do
+ cfs_type <- addHaddock (cfs_type cfs)
+ return $ case cfs_type of
+ L _ (HsDocTy _ ty doc) -> cfs { cfs_type = ty, cfs_doc = Just doc }
+ _ -> cfs { cfs_type }
instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where
addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -451,15 +451,16 @@ rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
rnHsConFieldSpec :: HsDocContext -> HsConFieldSpec on GhcPs
- -> RnM (HsConFieldSpec on GhcRn, FreeVars)
+ -> RnM (HsConFieldSpec on GhcRn, FreeVars)
rnHsConFieldSpec doc = rnHsConFieldSpecTyKi (mkTyKiEnv doc TypeLevel RnTypeBody)
rnHsConFieldSpecTyKi :: RnTyKiEnv -> HsConFieldSpec on GhcPs
- -> RnM (HsConFieldSpec on GhcRn, FreeVars)
-rnHsConFieldSpecTyKi env (CFS ext unp str w ty) = do
+ -> RnM (HsConFieldSpec on GhcRn, FreeVars)
+rnHsConFieldSpecTyKi env (CFS ext unp str w ty doc) = do
(w' , fvs_w) <- rnHsMultAnnOn env w
(ty', fvs) <- rnLHsTyKi env ty
- return (CFS ext unp str w' ty', fvs `plusFV` fvs_w)
+ doc' <- traverse rnLHsDoc doc
+ return (CFS ext unp str w' ty' doc', fvs `plusFV` fvs_w)
rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
@@ -1329,11 +1330,10 @@ rnConDeclFields ctxt fls fields
rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
-rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))
+rnField fl_env env (L l (ConDeclField _ names ty))
= do { let new_names = map (fmap (lookupField fl_env)) names
; (new_ty, fvs) <- rnHsConFieldSpecTyKi env ty
- ; haddock_doc' <- traverse rnLHsDoc haddock_doc
- ; return (L l (ConDeclField noExtField new_names new_ty haddock_doc')
+ ; return (L l (ConDeclField noExtField new_names new_ty)
, fvs) }
lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn
@@ -2049,7 +2049,7 @@ extract_scaled_ltys args acc = foldr extract_scaled_lty acc args
extract_scaled_lty :: HsConFieldSpec on GhcPs
-> FreeKiTyVars -> FreeKiTyVars
-extract_scaled_lty (CFS _ _ _ m ty) acc = extract_lty ty $ extract_hs_mult_ann_on m acc
+extract_scaled_lty (CFS _ _ _ m ty _) acc = extract_lty ty $ extract_hs_mult_ann_on m acc
extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
extract_ltys tys acc = foldr extract_lty acc tys
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -1802,8 +1802,8 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc
kcConArgTys :: NewOrData -> TcKind -> [HsConFieldSpec on GhcRn] -> TcM ()
kcConArgTys new_or_data res_kind arg_tys = do
{ let exp_kind = getArgExpKind new_or_data res_kind
- ; forM_ arg_tys (\(CFS _ _ _ mult ty) -> do _ <- tcCheckLHsTypeInContext ty exp_kind
- tcMult mult)
+ ; forM_ arg_tys (\(CFS _ _ _ mult ty _) -> do _ <- tcCheckLHsTypeInContext ty exp_kind
+ tcMult mult)
-- See Note [Implementation of UnliftedNewtypes], STEP 2
}
@@ -3925,7 +3925,7 @@ tcConGADTArgs exp_kind (RecConGADT _ fields)
tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes,
-- but might be an unlifted type with UnliftedNewtypes
-> HsConFieldSpec on GhcRn -> TcM (Scaled TcType, HsSrcBang)
-tcConArg exp_kind (CFS (_, src) unp str w bty)
+tcConArg exp_kind (CFS (_, src) unp str w bty _)
= do { traceTc "tcConArg 1" (ppr bty)
; arg_ty <- tcCheckLHsTypeInContext bty exp_kind
; w' <- tcDataConMult w
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -782,7 +782,7 @@ cvt_arg (Bang su ss, ty)
; let ty' = parenthesizeHsType appPrec ty''
su' = cvtSrcUnpackedness su
ss' = cvtSrcStrictness ss
- ; return $ CFS noAnn su' ss' hsNoMultAnn ty' }
+ ; return $ CFS noAnn su' ss' hsNoMultAnn ty' Nothing }
cvt_id_arg :: TH.Name -- ^ parent constructor name
-> (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
@@ -793,8 +793,7 @@ cvt_id_arg parent_con (i, str, ty)
{ cd_fld_ext = noExtField
, cd_fld_names
= [L (l2l li) $ FieldOcc noExtField (L li i')]
- , cd_fld_spec = ty'
- , cd_fld_doc = Nothing} }
+ , cd_fld_spec = ty' } }
cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs cs = do { mapM cvtDerivClause cs }
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -1077,12 +1077,11 @@ data HsTupleSort = HsUnboxedTuple
type LConDeclField pass = XRec pass (ConDeclField pass)
-- | Constructor Declaration Field
-data ConDeclField pass -- Record fields have Haddock docs on them
+data ConDeclField pass
= ConDeclField { cd_fld_ext :: XConDeclField pass,
cd_fld_names :: [LFieldOcc pass],
-- ^ See Note [ConDeclField pass]
- cd_fld_spec :: HsConFieldSpec OnRecField pass,
- cd_fld_doc :: Maybe (LHsDoc pass)}
+ cd_fld_spec :: HsConFieldSpec OnRecField pass }
| XConDeclField !(XXConDeclField pass)
-- | Describes the arguments to a data constructor. This is a common
@@ -1117,7 +1116,8 @@ data HsConFieldSpec on pass
, cfs_unpack :: SrcUnpackedness
, cfs_bang :: SrcStrictness
, cfs_multiplicity :: HsMultAnnOn on (LHsType pass) pass
- , cfs_type :: LHsType pass }
+ , cfs_type :: LHsType pass
+ , cfs_doc :: Maybe (LHsDoc pass) }
hsConFieldSpecGeneralize :: HsConFieldSpec on pass -> HsConFieldSpec on1 pass
hsConFieldSpecGeneralize = unsafeCoerce
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -4424,10 +4424,10 @@ instance ExactPrint (ConDeclField GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (ConDeclField _ names ftype mdoc) = do
+ exact (ConDeclField _ names ftype) = do
names' <- markAnnotated names
ftype' <- markAnnotated ftype
- return (ConDeclField noExtField names' ftype' mdoc)
+ return (ConDeclField noExtField names' ftype')
-- ---------------------------------------------------------------------
@@ -4443,20 +4443,20 @@ instance ExactPrint (FieldOcc GhcPs) where
instance ExactPrint (HsConFieldSpec OnArrow GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (CFS an unp str arr t) = do
+ exact (CFS an unp str arr t doc) = do
an' <- exactBang an str
t' <- markAnnotated t
arr' <- markArrow arr
- return (CFS an' unp str arr' t')
+ return (CFS an' unp str arr' t' doc)
instance ExactPrint (HsConFieldSpec OnRecField GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (CFS an unp str mult t) = do
+ exact (CFS an unp str mult t doc) = do
mult' <- markRecFieldMult mult
an' <- exactBang an str
t' <- markAnnotated t
- return (CFS an' unp str mult' t')
+ return (CFS an' unp str mult' t' doc)
exactBang :: (Monoid w, Monad m) => XConFieldSpec GhcPs -> SrcStrictness -> EP w m (XConFieldSpec GhcPs)
exactBang ((o,c,tk), mt) str = do
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
=====================================
@@ -1031,7 +1031,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
-- | Pretty-print a record field
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX
-ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
+ppSideBySideField subdocs unicode (ConDeclField _ names ltype) =
decltt
( cat (punctuate comma (map (ppBinder . rdrNameOcc . foExt . unLoc) names))
<+> ppRecFieldMultAnn unicode ltype (dcolon unicode)
@@ -1039,16 +1039,16 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
)
<-> rDoc mbDoc
where
- -- don't use cd_fld_doc for same reason we don't use con_doc above
- -- Where there is more than one name, they all have the same documentation
mbDoc = lookup (unLoc . foLabel . unLoc $ name) subdocs >>= fmap _doc . combineDocumentation . fst
name =
case Maybe.listToMaybe names of
Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
Just hd -> hd
+-- don't use cfs_doc for same reason we don't use con_doc above
+-- Where there is more than one name, they all have the same documentation
ppRecFieldMultAnn :: Bool -> HsConFieldSpec on DocNameI -> LaTeX -> LaTeX
-ppRecFieldMultAnn unicode (CFS _ _ _ arr _) following = case arr of
+ppRecFieldMultAnn unicode (CFS _ _ _ arr _ _) following = case arr of
HsUnannotated _ _ -> following
HsLinearAnn _ -> text "%1" <+> following
HsExplicitMult _ mult -> multAnnotation <> ppr_mono_lty mult unicode <+> following
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
=====================================
@@ -1533,7 +1533,7 @@ ppSideBySideField
-> Qualification
-> ConDeclField DocNameI
-> SubDecl
-ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
+ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype) =
( hsep
( punctuate
comma
@@ -1548,21 +1548,21 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
, []
)
where
- -- don't use cd_fld_doc for same reason we don't use con_doc above
- -- Where there is more than one name, they all have the same documentation
mbDoc = lookup (unLoc . foLabel $ unLoc declName) subdocs >>= combineDocumentation . fst
declName = case Maybe.listToMaybe names of
Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
Just hd -> hd
+-- don't use cfs_doc for same reason we don't use con_doc above
+-- Where there is more than one name, they all have the same documentation
ppRecFieldMultAnn :: Unicode -> Qualification -> HsConFieldSpec on DocNameI -> Html -> Html
-ppRecFieldMultAnn unicode qual (CFS _ _ _ arr _) following = case arr of
+ppRecFieldMultAnn unicode qual (CFS _ _ _ arr _ _) following = case arr of
HsUnannotated _ _ -> following
HsLinearAnn _ -> toHtml "%1" <+> following
HsExplicitMult _ mult -> multAnnotation <> ppr_mono_lty mult unicode qual HideEmptyContexts <+> following
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
-ppShortField summary unicode qual (ConDeclField _ names ltype _) =
+ppShortField summary unicode qual (ConDeclField _ names ltype) =
hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . foExt . unLoc) names))
<+> ppRecFieldMultAnn unicode qual ltype (dcolon unicode)
<+> ppLType unicode qual HideEmptyContexts (hsConFieldSpecToHsTypeNoMult ltype)
=====================================
utils/haddock/haddock-api/src/Haddock/Convert.hs
=====================================
@@ -497,7 +497,7 @@ synifyDataCon use_gadt_syntax dc =
( \(Scaled mult ty) (HsSrcBang st (HsBang unp str)) ->
let tySyn = synifyType WithinType [] ty
multSyn = synifyMultRec [] mult
- in CFS (noAnn, st) unp str multSyn tySyn
+ in CFS (noAnn, st) unp str multSyn tySyn Nothing
)
arg_tys
(dataConSrcBangs dc)
@@ -509,7 +509,6 @@ synifyDataCon use_gadt_syntax dc =
noExtField
[noLocA $ FieldOcc (mkVarUnqual $ field_label $ flLabel fl) (noLocA (flSelector fl))]
synTy
- Nothing
mk_h98_arg_tys :: Either String (HsConDeclH98Details GhcRn)
mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -196,10 +196,10 @@ hsConFieldSpecToFunTy (hsConFieldSpecGeneralize -> cfs) tgt =
noLocA (HsFunTy noAnn (cfs_multiplicity cfs) (hsConFieldSpecToHsTypeNoMult cfs) tgt)
hsConFieldSpecToHsTypeNoMult
- :: (XRec pass (HsType pass) ~ GenLocated e (HsType pass), HasAnnotation e, NoAnn (XBangTy pass), XXType pass ~ HsTypeGhcPsExt pass)
+ :: (XRec pass (HsType pass) ~ GenLocated e (HsType pass), HasAnnotation e, NoAnn (XBangTy pass), NoAnn (XDocTy pass), XXType pass ~ HsTypeGhcPsExt pass)
=> HsConFieldSpec on pass -> LHsType pass
-hsConFieldSpecToHsTypeNoMult (CFS _ unp str _ t) = case t of
- L l (HsDocTy x ty doc) -> L l (HsDocTy x (mkBang unp str ty) doc)
+hsConFieldSpecToHsTypeNoMult (CFS _ unp str _ t doc) = case doc of
+ Just doc' -> noLocA (HsDocTy noAnn (mkBang unp str t) doc')
_ -> mkBang unp str t
where
mkBang NoSrcUnpack NoSrcStrict ty = ty
@@ -373,11 +373,11 @@ restrictCons names decls = [L p d | L p (Just d) <- fmap keep <$> decls]
-- see above
field_avail :: LConDeclField GhcRn -> Bool
- field_avail (L _ (ConDeclField _ fs _ _)) =
+ field_avail (L _ (ConDeclField _ fs _)) =
all (\f -> (unLoc . foLabel . unLoc $ f) `elem` names) fs
field_types :: [LConDeclField GhcRn] -> [HsConFieldSpec OnArrow GhcRn]
- field_types flds = [hsConFieldSpecGeneralize t | L _ (ConDeclField _ _ t _) <- flds]
+ field_types flds = [hsConFieldSpecGeneralize t | L _ (ConDeclField _ _ t) <- flds]
keep _ = Nothing
restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]
@@ -526,7 +526,7 @@ reparenBndrKind v at XBndrKind{} = v
-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
reparenConDeclField :: XRecCond a => ConDeclField a -> ConDeclField a
-reparenConDeclField (ConDeclField x n (CFS an unp str m t) d) = ConDeclField x n (CFS an unp str m (reparenLType t)) d
+reparenConDeclField (ConDeclField x n (CFS an unp str m t d)) = ConDeclField x n (CFS an unp str m (reparenLType t) d)
reparenConDeclField c at XConDeclField{} = c
-------------------------------------------------------------------------------
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
=====================================
@@ -998,13 +998,13 @@ extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
case getRecConArgs_maybe con of
Just (L _ fields)
- | ((l, L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
+ | ((l, L _ (ConDeclField _ _nn ty)) : _) <- matching_fields fields ->
pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noExtField (HsUnrestrictedArrow noExtField) data_ty (cfs_type ty))))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
matching_fields flds =
- [ (locA l, f) | f@(L _ (ConDeclField _ ns _ _)) <- flds, L l n <- ns, unLoc (foLabel n) == nm
+ [ (locA l, f) | f@(L _ (ConDeclField _ ns _)) <- flds, L l n <- ns, unLoc (foLabel n) == nm
]
data_ty
-- ResTyGADT _ ty <- con_res con = ty
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -719,7 +719,11 @@ renameCon
renameHsConFieldSpec
:: HsConFieldSpec on GhcRn
-> RnM (HsConFieldSpec on DocNameI)
-renameHsConFieldSpec (CFS _ unp str w ty) = CFS noExtField unp str <$> renameMultAnnOn w <*> renameLType ty
+renameHsConFieldSpec (CFS _ unp str w ty doc) = do
+ w' <- renameMultAnnOn w
+ ty' <- renameLType ty
+ doc' <- mapM renameLDocHsSyn doc
+ return (CFS noExtField unp str w' ty' doc')
renameH98Details
:: HsConDeclH98Details GhcRn
@@ -742,11 +746,10 @@ renameGADTDetails (RecConGADT _ (L l fields)) = do
renameGADTDetails (PrefixConGADT _ ps) = PrefixConGADT noExtField <$> mapM renameHsConFieldSpec ps
renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
-renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
+renameConDeclFieldField (L l (ConDeclField _ names t)) = do
names' <- mapM renameLFieldOcc names
t' <- renameHsConFieldSpec t
- doc' <- mapM renameLDocHsSyn doc
- return $ L (locA l) (ConDeclField noExtField names' t' doc')
+ return $ L (locA l) (ConDeclField noExtField names' t')
renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
renameLFieldOcc (L l (FieldOcc rdr (L n sel))) = do
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e23f4d9982cf93120c71f3853ff56e5bee83fdb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e23f4d9982cf93120c71f3853ff56e5bee83fdb
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250121/ff57ee65/attachment-0001.html>
More information about the ghc-commits
mailing list