[Git][ghc/ghc][wip/T18462] Add HsConFieldSpec
Sjoerd Visscher (@trac-sjoerd_visscher)
gitlab at gitlab.haskell.org
Thu Jan 9 12:43:49 UTC 2025
Sjoerd Visscher pushed to branch wip/T18462 at Glasgow Haskell Compiler / GHC
Commits:
a28732e9 by Sjoerd Visscher at 2025-01-09T13:43:22+01:00
Add HsConFieldSpec
- - - - -
26 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- 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.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Type.hs
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.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
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -881,11 +881,11 @@ pprConDecl (ConDeclH98 { con_name = L _ con
where
-- In ppr_details: let's not print the multiplicities (they are always 1, by
-- definition) as they do not appear in an actual declaration.
- ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1),
+ ppr_details (InfixCon t1 t2) = hsep [pprHsConFieldSpecNoMult t1,
pprInfixOcc con,
- ppr (hsScaledThing t2)]
+ pprHsConFieldSpecNoMult t2]
ppr_details (PrefixCon _ tys) = hsep (pprPrefixOcc con
- : map (pprHsType . unLoc . hsScaledThing) tys)
+ : map pprHsConFieldSpecNoMult tys)
ppr_details (RecCon fields) = pprPrefixOcc con
<+> pprConDeclFields (unLoc fields)
@@ -896,7 +896,7 @@ pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs
<+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt,
sep (ppr_args args ++ [ppr res_ty]) ])
where
- ppr_args (PrefixConGADT _ args) = map (\(HsScaled arr t) -> ppr t <+> ppr_arr arr) args
+ ppr_args (PrefixConGADT _ args) = map (pprHsConFieldSpecWith (\arr tyDoc -> tyDoc <+> ppr_arr arr)) args
ppr_args (RecConGADT _ fields) = [pprConDeclFields (unLoc fields) <+> arrow]
-- Display linear arrows as unrestricted with -XNoLinearTypes
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -535,7 +535,7 @@ deriving instance Data (HsTyLit GhcPs)
deriving instance Data (HsTyLit GhcRn)
deriving instance Data (HsTyLit GhcTc)
--- deriving instance (Data mult, DataIdLR p p) => Data (HsArrowOf mult p)
+-- deriving instance (Data mult, DataIdLR p p, Typeable on) => Data (HsMultAnnOn on mult p)
deriving instance Data (HsMultAnnOn OnArrow (LocatedA (HsType GhcPs)) GhcPs)
deriving instance Data (HsMultAnnOn OnRecField (LocatedA (HsType GhcPs)) GhcPs)
deriving instance Typeable on => Data (HsMultAnnOn on (LocatedA (HsType GhcRn)) GhcRn)
@@ -545,7 +545,7 @@ deriving instance Data (HsMultAnnOn OnRecField (LocatedA (HsExpr
deriving instance Typeable on => Data (HsMultAnnOn on (LocatedA (HsExpr GhcRn)) GhcRn)
deriving instance Typeable on => Data (HsMultAnnOn on (LocatedA (HsExpr GhcTc)) GhcTc)
--- deriving instance (DataIdLR p p) => Data (HsScaled p a)
+-- deriving instance (DataIdLR p p, Typeable on) => Data (HsScaled on p a)
deriving instance Data thing => Data (HsScaled OnArrow GhcPs thing)
deriving instance Data thing => Data (HsScaled OnRecField GhcPs thing)
deriving instance (Data thing, Typeable on) => Data (HsScaled on GhcRn thing)
@@ -561,6 +561,12 @@ deriving instance Data (ConDeclField GhcPs)
deriving instance Data (ConDeclField GhcRn)
deriving instance Data (ConDeclField GhcTc)
+-- deriving instance (DataIdLR p p, Typeable on) => Data (HsConFieldSpec on p)
+deriving instance Data (HsConFieldSpec OnArrow GhcPs)
+deriving instance Data (HsConFieldSpec OnRecField GhcPs)
+deriving instance Typeable on => Data (HsConFieldSpec on GhcRn)
+deriving instance Typeable on => Data (HsConFieldSpec on GhcTc)
+
-- deriving instance (DataId p) => Data (FieldOcc p)
deriving instance Data (FieldOcc GhcPs)
deriving instance Data (FieldOcc GhcRn)
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -25,11 +25,11 @@ GHC.Hs.Type: Abstract syntax: user-defined types
module GHC.Hs.Type (
Mult, HsScaled(..),
- hsMultIsLinear, hsScaledThing, hsScaledToHsTypes,
+ hsMultIsLinear, hsScaledThing,
HsArrow, HsArrowOf, HsMultAnnOn(..), HsMultAnnOnWhat(..),
HsUnannotatedMult(..), pattern HsUnrestrictedArrow, multAnnToHsType, expandHsMultAnnOn,
EpLinearArrow(..),
- hsLinear, hsNoMultAnn, isUnrestricted,
+ hsNoMultAnn, isUnrestricted,
pprHsArrow,
HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,
@@ -61,6 +61,8 @@ module GHC.Hs.Type (
ConDeclField(..), LConDeclField, pprConDeclFields,
HsConDetails(..), noTypeArgs,
+ HsConFieldSpec(..), pprHsConFieldSpecWith, pprHsConFieldSpecNoMult,
+ hsPlainTypeField, hsConFieldSpecToHsTypes,
FieldOcc(..), LFieldOcc, mkFieldOcc,
fieldOccRdrName, fieldOccLRdrName,
@@ -482,6 +484,8 @@ type instance XSpliceTy GhcTc = Kind
type instance XDocTy (GhcPass _) = NoExtField
type instance XBangTy (GhcPass _) = ((EpaLocation, EpToken "#-}", EpaLocation), SourceText)
+type instance XConFieldSpec (GhcPass _) = ((EpaLocation, EpToken "#-}", EpaLocation), SourceText)
+type instance XXConDeclField (GhcPass _) = DataConCantHappen
type instance XRecTy GhcPs = AnnList ()
type instance XRecTy GhcRn = NoExtField
@@ -541,14 +545,8 @@ type instance XExplicitMult _ _ GhcTc = NoExtField
type instance XXMultAnnOn _ _ (GhcPass _) = DataConCantHappen
-hsLinear :: a -> HsScaled OnArrow GhcPs a
-hsLinear = HsScaled (HsLinearAnn noAnn)
-
-hsNoMultAnn :: a -> HsScaled OnRecField GhcPs a
-hsNoMultAnn = HsScaled (HsUnannotated HsUnannOne noAnn)
-
-hsScaledToHsTypes :: HsScaled on GhcRn (LHsType GhcRn) -> [LHsType GhcRn]
-hsScaledToHsTypes (HsScaled arr t) = [multAnnToHsType arr, t]
+hsNoMultAnn :: NoAnn (XUnannotated on (LHsType GhcPs) GhcPs) => HsMultAnnOn on (LHsType GhcPs) GhcPs
+hsNoMultAnn = HsUnannotated HsUnannOne noAnn
isUnrestricted :: HsArrow GhcRn -> Bool
isUnrestricted (multAnnToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName
@@ -582,16 +580,17 @@ type instance XXConDeclField (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
=> Outputable (ConDeclField (GhcPass p)) where
- ppr (ConDeclField _ fld_n (HsScaled fld_mult fld_ty) _) = ppr_names fld_n <+> ppr_mult <+> ppr fld_ty
+ ppr (ConDeclField _ fld_n cfs _) = ppr_names fld_n <+> pprHsConFieldSpecWith ppr_mult cfs
where
ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc
ppr_names [n] = pprPrefixOcc n
ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns))
- ppr_mult = case fld_mult of
- HsUnannotated _ _ -> dcolon
- HsLinearAnn _ -> text "%1" <+> dcolon
- HsExplicitMult _ p -> text "%" <> ppr p <+> dcolon
+ ppr_mult :: HsMultAnnOn on (LHsType (GhcPass p)) (GhcPass p) -> SDoc -> SDoc
+ ppr_mult mult tyDoc = case mult of
+ HsUnannotated _ _ -> dcolon <+> tyDoc
+ HsLinearAnn _ -> text "%1" <+> dcolon <+> tyDoc
+ HsExplicitMult _ p -> text "%" <> ppr p <+> dcolon <+> tyDoc
---------------------
hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]
@@ -723,10 +722,10 @@ mkHsAppKindTy at ty k = addCLocA ty k (HsAppKindTy at ty k)
-- splitHsFunType (a -> (b -> c)) = ([a,b], c)
-- It returns API Annotations for any parens removed
splitHsFunType ::
- LHsType (GhcPass p)
+ LHsType GhcPs
-> ( ([EpToken "("], [EpToken ")"]) , EpAnnComments -- The locations of any parens and
-- comments discarded
- , [HsScaled OnArrow (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))
+ , [HsConFieldSpec OnArrow GhcPs], LHsType GhcPs)
splitHsFunType ty = go ty
where
go (L l (HsParTy (op,cp) ty))
@@ -737,7 +736,7 @@ splitHsFunType ty = go ty
go (L ll (HsFunTy _ mult x y))
| (anns, csy, args, res) <- splitHsFunType y
- = (anns, csy S.<> epAnnComments ll, HsScaled mult x:args, res)
+ = (anns, csy S.<> epAnnComments ll, CFS noAnn NoSrcUnpack NoSrcStrict mult x:args, res)
go other = (noAnn, emptyComments, [], other)
@@ -1297,6 +1296,19 @@ 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 ty) = ppr_mult mult (ppr prag <+> ppr mark <> ppr ty)
+
+pprHsConFieldSpecNoMult :: (OutputableBndrId p) => HsConFieldSpec on (GhcPass p) -> SDoc
+pprHsConFieldSpecNoMult = pprHsConFieldSpecWith (\_ d -> d)
+
+hsPlainTypeField :: LHsType GhcPs -> HsConFieldSpec OnArrow GhcPs
+hsPlainTypeField (L _ (HsBangTy ann (HsBang unp str) lty)) = CFS ann unp str (HsLinearAnn noAnn) lty
+hsPlainTypeField lty = CFS noAnn NoSrcUnpack NoSrcStrict (HsLinearAnn noAnn) lty
+
+hsConFieldSpecToHsTypes :: HsConFieldSpec on GhcRn -> [LHsType GhcRn]
+hsConFieldSpecToHsTypes (CFS _ _ _ arr t) = [multAnnToHsType arr, t]
+
instance Outputable (XRecGhc (IdGhcP p)) =>
Outputable (FieldOcc (GhcPass p)) where
ppr = ppr . foLabel
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -430,14 +430,14 @@ 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 . hsScaledThing) args
- InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)
- , unLoc (hsScaledThing arg2) ]
+ 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) ]
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 . hsScaledThing) args ++ [res_ty]
+ PrefixConGADT _ args -> con_arg_docs 0 $ map (unLoc . cfs_type) args ++ [res_ty]
RecConGADT _ _ -> con_arg_docs 1 [res_ty]
con_arg_docs :: Int -> [HsType GhcRn] -> IntMap (HsDoc GhcRn)
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -920,17 +920,13 @@ repSrcStrictness SrcLazy = rep2 sourceLazyName []
repSrcStrictness SrcStrict = rep2 sourceStrictName []
repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
-repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType))
-repBangTy ty = do
- MkC u <- repSrcUnpackedness su'
- MkC s <- repSrcStrictness ss'
+repConFieldSpec :: HsConFieldSpec on GhcRn -> MetaM (Core (M TH.BangType))
+repConFieldSpec (CFS _ su ss _ ty') = do
+ MkC u <- repSrcUnpackedness su
+ MkC s <- repSrcStrictness ss
MkC b <- rep2 bangName [u, s]
MkC t <- repLTy ty'
rep2 bangTypeName [b, t]
- where
- (su', ss', ty') = case unLoc ty of
- HsBangTy _ (HsBang su ss) ty -> (su, ss, ty)
- _ -> (NoSrcUnpack, NoSrcStrict, ty)
-------------------------------------------------------
-- Deriving clauses
@@ -2838,8 +2834,8 @@ repH98DataCon con details
rep2 normalCName [unC con', unC arg_tys]
InfixCon st1 st2 -> do
verifyLinearFields [st1, st2]
- arg1 <- repBangTy (hsScaledThing st1)
- arg2 <- repBangTy (hsScaledThing st2)
+ arg1 <- repConFieldSpec st1
+ arg2 <- repConFieldSpec st2
rep2 infixCName [unC arg1, unC con', unC arg2]
RecCon ips -> do
arg_vtys <- repRecConArgs ips
@@ -2865,33 +2861,33 @@ repGadtDataCons cons details res_ty
-- TH currently only supports linear constructors.
-- We also accept the (->) arrow when -XLinearTypes is off, because this
-- denotes a linear field.
-verifyLinearFields :: [HsScaled on GhcRn (LHsType GhcRn)] -> MetaM ()
+verifyLinearFields :: [HsConFieldSpec on GhcRn] -> MetaM ()
verifyLinearFields ps = do
linear <- lift $ xoptM LangExt.LinearTypes
- let allGood = all (hsMultIsLinear linear) ps
+ let allGood = all (hsMultIsLinear linear . cfs_multiplicity) ps
unless allGood $ notHandled ThNonLinearDataCon
-- Desugar the arguments in a data constructor declared with prefix syntax.
-repPrefixConArgs :: [HsScaled OnArrow GhcRn (LHsType GhcRn)]
+repPrefixConArgs :: [HsConFieldSpec OnArrow GhcRn]
-> MetaM (Core [M TH.BangType])
repPrefixConArgs ps = do
verifyLinearFields ps
- repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
+ repListM bangTypeTyConName repConFieldSpec ps
-- Desugar the arguments in a data constructor declared with record syntax.
repRecConArgs :: LocatedL [LConDeclField GhcRn]
-> MetaM (Core [M TH.VarBangType])
repRecConArgs lips = do
let ips = map unLoc (unLoc lips)
- verifyLinearFields (map cd_fld_type ips)
+ verifyLinearFields (map cd_fld_spec ips)
args <- concatMapM rep_ip ips
coreListM varBangTypeTyConName args
where
- rep_ip ip = mapM (rep_one_ip (hsScaledThing $ cd_fld_type ip)) (cd_fld_names ip)
+ rep_ip ip = mapM (rep_one_ip (cd_fld_spec ip)) (cd_fld_names ip)
- rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
+ rep_one_ip :: HsConFieldSpec OnRecField GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
rep_one_ip t n = do { MkC v <- lookupOcc (unLoc . foLabel $ unLoc n)
- ; MkC ty <- repBangTy t
+ ; MkC ty <- repConFieldSpec t
; rep2 varBangTypeName [v,ty] }
------------ Types -------------------
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1789,8 +1789,8 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where
PrefixCon _ xs -> scaled_args_scope xs
InfixCon a b -> scaled_args_scope [a, b]
RecCon x -> mkScope x
- where scaled_args_scope :: [HsScaled on GhcRn (LHsType GhcRn)] -> Scope
- scaled_args_scope = foldr combineScopes NoScope . map (mkScope . hsScaledThing)
+ where scaled_args_scope :: [HsConFieldSpec on GhcRn] -> Scope
+ scaled_args_scope = foldr combineScopes NoScope . map (mkScope . cfs_type)
instance ToHie (LocatedL [LocatedA (ConDeclField GhcRn)]) where
toHie (L span decls) = concatM $
@@ -1798,6 +1798,9 @@ instance ToHie (LocatedL [LocatedA (ConDeclField GhcRn)]) where
, toHie decls
]
+instance ToHie (HsConFieldSpec on GhcRn) where
+ toHie (CFS _ _ _ w t) = concatM [toHie (multAnnToHsType w), toHie t]
+
instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsSigType GhcRn)))) where
toHie (TS sc (HsWC names a)) = concatM $
[ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
@@ -2000,7 +2003,7 @@ 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 ->
- [ toHie $ map (RFC RecFieldDecl (getRealSpan $ getHasLoc $ hsScaledThing typ)) fields
+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ getHasLoc $ cfs_type typ)) fields
, toHie typ
, toHie doc
]
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2598,7 +2598,7 @@ fielddecl :: { LConDeclField GhcPs }
(ConDeclField noExtField
(reverse (map (\ln@(L l n)
-> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1)))
- (HsScaled (HsUnannotated HsUnannOne (epUniTok $2)) $3)
+ (mkConFieldSpec (HsUnannotated HsUnannOne (epUniTok $2)) $3)
Nothing))}
| sig_vars PREFIX_PERCENT atype '::' ctype
{% amsA' (L (comb4 $1 $2 $3 $5)
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -72,6 +72,7 @@ module GHC.Parser.PostProcess (
mkMultTy,
mkMultAnn,
mkMultField,
+ mkConFieldSpec,
-- Token location
mkTokenLocation,
@@ -2337,11 +2338,11 @@ dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))
-- Normal prefix constructor, e.g. data T = MkT A B C
dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))
- = PrefixCon noTypeArgs (map hsLinear (toList flds))
+ = PrefixCon noTypeArgs (map hsPlainTypeField (toList flds))
-- Infix constructor, e.g. data T = Int :! Bool
dataConBuilderDetails (L (EpAnn _ _ csl) (InfixDataConBuilder (L (EpAnn anc ann csll) lhs) _ rhs))
- = InfixCon (hsLinear (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsLinear rhs)
+ = InfixCon (hsPlainTypeField (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsPlainTypeField rhs)
instance DisambTD DataConBuilder where
@@ -2409,7 +2410,7 @@ checkNotPromotedDataCon IsPromoted (L l name) =
mkUnboxedSumCon :: LHsType GhcPs -> ConTag -> Arity -> (LocatedN RdrName, HsConDeclH98Details GhcPs)
mkUnboxedSumCon t tag arity =
- (noLocA (getRdrName (sumDataCon tag arity)), PrefixCon noTypeArgs [hsLinear t])
+ (noLocA (getRdrName (sumDataCon tag arity)), PrefixCon noTypeArgs [hsPlainTypeField t])
{- Note [Ambiguous syntactic categories]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3519,15 +3520,19 @@ mkMultAnn pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1)))
pct1 = epTokenWidenR pct (locA (getLoc t))
mkMultAnn pct t = HsMultAnn pct t
-mkMultField :: EpToken "%" -> LHsType GhcPs -> TokDcolon -> LHsType GhcPs -> HsScaled OnRecField GhcPs (LBangType GhcPs)
+mkMultField :: EpToken "%" -> LHsType GhcPs -> TokDcolon -> LHsType GhcPs -> HsConFieldSpec OnRecField GhcPs
mkMultField pct (L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) col t
-- See #18888 for the use of (SourceText "1") above
- = HsScaled (HsLinearAnn (pct1, col)) t
+ = mkConFieldSpec (HsLinearAnn (pct1, col)) t
where
-- The location of "%" combined with the location of "1".
pct1 :: EpToken "%1"
pct1 = epTokenWidenR pct (locA (getLoc t))
-mkMultField pct mult col t = HsScaled (HsExplicitMult (pct, col) mult) t
+mkMultField pct mult col t = mkConFieldSpec (HsExplicitMult (pct, col) mult) t
+
+mkConFieldSpec :: HsMultAnnOn on (LHsType GhcPs) GhcPs -> LHsType GhcPs -> HsConFieldSpec on GhcPs
+mkConFieldSpec mult (L _ (HsBangTy ann (HsBang unp str) t)) = CFS ann unp str mult t
+mkConFieldSpec mult t = CFS noAnn NoSrcUnpack NoSrcStrict mult t
mkTokenLocation :: SrcSpan -> TokenLocation
mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc
=====================================
compiler/GHC/Parser/PostProcess/Haddock.hs
=====================================
@@ -788,12 +788,12 @@ getConDoc l = extendHdkA l $ liftHdkA $ getPrevNextDoc l
-- Add documentation comment to a data constructor field.
-- Used for PrefixCon and InfixCon.
addHaddockConDeclFieldTy
- :: HsScaled on GhcPs (LHsType GhcPs)
- -> HdkA (HsScaled on GhcPs (LHsType GhcPs))
-addHaddockConDeclFieldTy (HsScaled mult (L l t)) =
+ :: 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 (HsScaled mult (mkLHsDocTy (L l t) mDoc))
+ return (CFS ann unpack strict mult (mkLHsDocTy (L l t) mDoc))
-- Add documentation comment to a data constructor field.
-- Used for RecCon.
@@ -909,6 +909,9 @@ We implement this in two steps:
instance HasHaddock a => HasHaddock (HsScaled on GhcPs a) where
addHaddock (HsScaled mult a) = HsScaled mult <$> addHaddock a
+instance HasHaddock (HsConFieldSpec on GhcPs) where
+ addHaddock (CFS ann unp str mult a) = CFS ann unp str mult <$> addHaddock a
+
instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where
addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Rename.HsType (
lookupField, mkHsOpTyRn,
rnLTyVar,
- rnScaledLHsType,
+ rnHsConFieldSpec,
-- Precence related stuff
NegationHandling(..),
@@ -450,16 +450,16 @@ rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
-rnScaledLHsType :: HsDocContext -> HsScaled on GhcPs (LHsType GhcPs)
- -> RnM (HsScaled on GhcRn (LHsType GhcRn), FreeVars)
-rnScaledLHsType doc = rnScaledLHsTyKi (mkTyKiEnv doc TypeLevel RnTypeBody)
+rnHsConFieldSpec :: HsDocContext -> HsConFieldSpec on GhcPs
+ -> RnM (HsConFieldSpec on GhcRn, FreeVars)
+rnHsConFieldSpec doc = rnHsConFieldSpecTyKi (mkTyKiEnv doc TypeLevel RnTypeBody)
-rnScaledLHsTyKi :: RnTyKiEnv -> HsScaled on GhcPs (LHsType GhcPs)
- -> RnM (HsScaled on GhcRn (LHsType GhcRn), FreeVars)
-rnScaledLHsTyKi env (HsScaled w ty) = do
+rnHsConFieldSpecTyKi :: RnTyKiEnv -> HsConFieldSpec on GhcPs
+ -> RnM (HsConFieldSpec on GhcRn, FreeVars)
+rnHsConFieldSpecTyKi env (CFS ext unp str w ty) = do
(w' , fvs_w) <- rnHsMultAnnOn env w
(ty', fvs) <- rnLHsTyKi env ty
- return (HsScaled w' ty', fvs `plusFV` fvs_w)
+ return (CFS ext unp str w' ty', fvs `plusFV` fvs_w)
rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
@@ -1339,7 +1339,7 @@ rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))
= do { let new_names = map (fmap (lookupField fl_env)) names
- ; (new_ty, fvs) <- rnScaledLHsTyKi env ty
+ ; (new_ty, fvs) <- rnHsConFieldSpecTyKi env ty
; haddock_doc' <- traverse rnLHsDoc haddock_doc
; return (L l (ConDeclField noExtField new_names new_ty haddock_doc')
, fvs) }
@@ -2035,7 +2035,7 @@ extractConDeclGADTDetailsTyVars ::
HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars
extractConDeclGADTDetailsTyVars con_args = case con_args of
PrefixConGADT _ args -> extract_scaled_ltys args
- RecConGADT _ (L _ flds) -> extract_scaled_ltys $ map (cd_fld_type . unLoc) $ flds
+ RecConGADT _ (L _ flds) -> extract_scaled_ltys $ map (cd_fld_spec . unLoc) $ flds
-- | Get type/kind variables mentioned in the kind signature, preserving
-- left-to-right order:
@@ -2051,13 +2051,13 @@ extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })
extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lctxt ctxt = extract_ltys (unLoc ctxt)
-extract_scaled_ltys :: [HsScaled on GhcPs (LHsType GhcPs)]
+extract_scaled_ltys :: [HsConFieldSpec on GhcPs]
-> FreeKiTyVars -> FreeKiTyVars
extract_scaled_ltys args acc = foldr extract_scaled_lty acc args
-extract_scaled_lty :: HsScaled on GhcPs (LHsType GhcPs)
+extract_scaled_lty :: HsConFieldSpec on GhcPs
-> FreeKiTyVars -> FreeKiTyVars
-extract_scaled_lty (HsScaled 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
@@ -2068,7 +2068,7 @@ extract_lty (L _ ty) acc
HsTyVar _ _ ltv -> extract_tv ltv acc
HsBangTy _ _ ty -> extract_lty ty acc
HsRecTy _ flds -> foldr (extract_scaled_lty
- . cd_fld_type . unLoc) acc
+ . cd_fld_spec . unLoc) acc
flds
HsAppTy _ ty1 ty2 -> extract_lty ty1 $
extract_lty ty2 acc
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -1928,9 +1928,7 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond
has_labelled_fields _ = False
has_strictness_flags condecl
- = any (is_strict . getBangStrictness . hsScaledThing) (con_args condecl)
-
- is_strict (HsSrcBang _ (HsBang _ s)) = isSrcStrict s
+ = any (isSrcStrict . cfs_bang) (con_args condecl)
con_args (ConDeclGADT { con_g_args = PrefixConGADT _ args }) = args
con_args (ConDeclH98 { con_args = PrefixCon _ args }) = args
@@ -2483,11 +2481,11 @@ rnConDeclH98Details ::
-> HsConDeclH98Details GhcPs
-> RnM (HsConDeclH98Details GhcRn, FreeVars)
rnConDeclH98Details _ doc (PrefixCon _ tys)
- = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys
+ = do { (new_tys, fvs) <- mapFvRn (rnHsConFieldSpec doc) tys
; return (PrefixCon noTypeArgs new_tys, fvs) }
rnConDeclH98Details _ doc (InfixCon ty1 ty2)
- = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1
- ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2
+ = do { (new_ty1, fvs1) <- rnHsConFieldSpec doc ty1
+ ; (new_ty2, fvs2) <- rnHsConFieldSpec doc ty2
; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
rnConDeclH98Details con doc (RecCon flds)
= do { (new_flds, fvs) <- rnRecConDeclFields con doc flds
@@ -2499,7 +2497,7 @@ rnConDeclGADTDetails ::
-> HsConDeclGADTDetails GhcPs
-> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
rnConDeclGADTDetails _ doc (PrefixConGADT _ tys)
- = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys
+ = do { (new_tys, fvs) <- mapFvRn (rnHsConFieldSpec doc) tys
; return (PrefixConGADT noExtField new_tys, fvs) }
rnConDeclGADTDetails con doc (RecConGADT _ flds)
= do { (new_flds, fvs) <- rnRecConDeclFields con doc flds
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -283,7 +283,7 @@ no_anon_wc_ty lty = go lty
HsKindSig _ ty kind -> go ty && go kind
HsDocTy _ ty _ -> go ty
HsBangTy _ _ ty -> go ty
- HsRecTy _ flds -> gos $ concatMap (hsScaledToHsTypes . cd_fld_type . unLoc) flds
+ HsRecTy _ flds -> gos $ concatMap (hsConFieldSpecToHsTypes . cd_fld_spec . unLoc) flds
HsExplicitListTy _ _ tys -> gos tys
HsExplicitTupleTy _ _ tys -> gos tys
HsForAllTy { hst_tele = tele
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -1799,11 +1799,11 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc
-- This includes doing kind unification if the type is a newtype.
-- See Note [Implementation of UnliftedNewtypes] for why we need
-- the first two arguments.
-kcConArgTys :: NewOrData -> TcKind -> [HsScaled on GhcRn (LHsType GhcRn)] -> TcM ()
+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 (\(HsScaled mult ty) -> do _ <- tcCheckLHsTypeInContext (getBangType ty) exp_kind
- tcMult mult)
+ ; forM_ arg_tys (\(CFS _ _ _ mult ty) -> do _ <- tcCheckLHsTypeInContext (getBangType ty) exp_kind
+ tcMult mult)
-- See Note [Implementation of UnliftedNewtypes], STEP 2
}
@@ -1813,14 +1813,14 @@ kcConH98Args new_or_data res_kind con_args = case con_args of
PrefixCon _ tys -> kcConArgTys new_or_data res_kind tys
InfixCon ty1 ty2 -> kcConArgTys new_or_data res_kind [ty1, ty2]
RecCon (L _ flds) -> kcConArgTys new_or_data res_kind $
- map (cd_fld_type . unLoc) flds
+ map (cd_fld_spec . unLoc) flds
-- Kind-check the types of arguments to a GADT data constructor.
kcConGADTArgs :: NewOrData -> TcKind -> HsConDeclGADTDetails GhcRn -> TcM ()
kcConGADTArgs new_or_data res_kind con_args = case con_args of
PrefixConGADT _ tys -> kcConArgTys new_or_data res_kind tys
RecConGADT _ (L _ flds) -> kcConArgTys new_or_data res_kind $
- map (cd_fld_type . unLoc) flds
+ map (cd_fld_spec . unLoc) flds
kcConDecls :: Foldable f
=> NewOrData
@@ -3893,7 +3893,7 @@ tcConIsInfixGADT con details
RecConGADT{} -> return False
PrefixConGADT _ arg_tys -- See Note [Infix GADT constructors]
| isSymOcc (getOccName con)
- , [_ty1,_ty2] <- map hsScaledThing arg_tys
+ , [_ty1,_ty2] <- arg_tys
-> do { fix_env <- getFixityEnv
; return (con `elemNameEnv` fix_env) }
| otherwise -> return False
@@ -3924,13 +3924,13 @@ tcConGADTArgs exp_kind (RecConGADT _ fields)
tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes,
-- but might be an unlifted type with UnliftedNewtypes
- -> HsScaled on GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang)
-tcConArg exp_kind (HsScaled w bty)
+ -> HsConFieldSpec on GhcRn -> TcM (Scaled TcType, HsSrcBang)
+tcConArg exp_kind (CFS (_, src) unp str w bty)
= do { traceTc "tcConArg 1" (ppr bty)
; arg_ty <- tcCheckLHsTypeInContext (getBangType bty) exp_kind
; w' <- tcDataConMult w
; traceTc "tcConArg 2" (ppr bty)
- ; return (Scaled w' arg_ty, getBangStrictness bty) }
+ ; return (Scaled w' arg_ty, HsSrcBang src (HsBang unp str)) }
tcRecConDeclFields :: ContextKind
-> LocatedL [LConDeclField GhcRn]
@@ -3939,7 +3939,7 @@ tcRecConDeclFields exp_kind fields
= mapM (tcConArg exp_kind) btys
where
-- We need a one-to-one mapping from field_names to btys
- combined = map (\(L _ f) -> (cd_fld_names f, cd_fld_type f))
+ combined = map (\(L _ f) -> (cd_fld_names f, cd_fld_spec f))
(unLoc fields)
explode (ns,ty) = zip ns (repeat ty)
exploded = concatMap explode combined
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -3,6 +3,7 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -689,7 +690,7 @@ cvtConstr :: TH.Name -- ^ name of first constructor of parent type
cvtConstr _ do_con_name (NormalC c strtys)
= do { c' <- do_con_name c
; tys' <- mapM cvt_arg strtys
- ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) }
+ ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs tys') }
cvtConstr parent_con do_con_name (RecC c varstrtys)
= do { c' <- do_con_name c
@@ -702,7 +703,7 @@ cvtConstr _ do_con_name (InfixC st1 c st2)
; st1' <- cvt_arg st1
; st2' <- cvt_arg st2
; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing
- (InfixCon (hsLinear st1') (hsLinear st2')) }
+ (InfixCon st1' st2') }
cvtConstr parent_con do_con_name (ForallC tvs ctxt con)
= do { tvs' <- cvtTvs tvs
@@ -741,7 +742,7 @@ cvtConstr _ do_con_name (GadtC c strtys ty) = case nonEmpty c of
{ c' <- mapM do_con_name c
; args <- mapM cvt_arg strtys
; ty' <- cvtType ty
- ; mk_gadt_decl c' (PrefixConGADT noExtField $ map hsLinear args) ty'}
+ ; mk_gadt_decl c' (PrefixConGADT noExtField args) ty'}
cvtConstr parent_con do_con_name (RecGadtC c varstrtys ty) = case nonEmpty c of
Nothing -> failWith RecGadtNoCons
@@ -775,13 +776,13 @@ cvtSrcStrictness NoSourceStrictness = NoSrcStrict
cvtSrcStrictness SourceLazy = SrcLazy
cvtSrcStrictness SourceStrict = SrcStrict
-cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
+cvt_arg :: NoAnn (XUnannotated on (LHsType GhcPs) GhcPs) => (TH.Bang, TH.Type) -> CvtM (HsConFieldSpec on GhcPs)
cvt_arg (Bang su ss, ty)
= do { ty'' <- cvtType ty
; let ty' = parenthesizeHsType appPrec ty''
su' = cvtSrcUnpackedness su
ss' = cvtSrcStrictness ss
- ; returnLA $ HsBangTy (noAnn, NoSourceText) (HsBang su' ss') ty' }
+ ; return $ CFS noAnn su' ss' hsNoMultAnn ty' }
cvt_id_arg :: TH.Name -- ^ parent constructor name
-> (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
@@ -792,7 +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_type = hsNoMultAnn ty'
+ , cd_fld_spec = ty'
, cd_fld_doc = Nothing} }
cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -1122,7 +1122,7 @@ or contexts in two parts:
-- | The arguments in a Haskell98-style data constructor.
type HsConDeclH98Details pass
- = HsConDetails Void (HsScaled OnArrow pass (LBangType pass)) (XRec pass [LConDeclField pass])
+ = HsConDetails Void (HsConFieldSpec OnArrow pass) (XRec pass [LConDeclField pass])
-- The Void argument to HsConDetails here is a reflection of the fact that
-- type applications are not allowed in data constructor declarations.
@@ -1133,7 +1133,7 @@ type HsConDeclH98Details pass
-- derived Show instances—see Note [Infix GADT constructors] in
-- GHC.Tc.TyCl—but that is an orthogonal concern.)
data HsConDeclGADTDetails pass
- = PrefixConGADT !(XPrefixConGADT pass) [HsScaled OnArrow pass (LBangType pass)]
+ = PrefixConGADT !(XPrefixConGADT pass) [HsConFieldSpec OnArrow pass]
| RecConGADT !(XRecConGADT pass) (XRec pass [LConDeclField pass])
| XConDeclGADTDetails !(XXConDeclGADTDetails pass)
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -682,6 +682,11 @@ type family XXTyVarBndr x
type family XConDeclField x
type family XXConDeclField x
+-- ---------------------------------------------------------------------
+-- ConFieldSpec type families
+type family XConFieldSpec x
+type family XXConFieldSpec x
+
-- ---------------------------------------------------------------------
-- FieldOcc type families
type family XCFieldOcc x
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -23,7 +23,7 @@ GHC.Hs.Type: Abstract syntax: user-defined types
-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*
module Language.Haskell.Syntax.Type (
HsScaled(..),
- hsMultIsLinear, hsScaledThing, hsScaledGeneralize,
+ hsMultIsLinear, hsScaledThing,
HsArrow, HsArrowOf, HsMultAnnOn(..), HsMultAnnOnWhat(..), HsUnannotatedMult(..),
pattern HsUnrestrictedArrow,
XUnannotated, XLinearAnn, XExplicitMult, XXMultAnnOn,
@@ -57,6 +57,7 @@ module Language.Haskell.Syntax.Type (
ConDeclField(..), LConDeclField,
HsConDetails(..), noTypeArgs,
+ HsConFieldSpec(..), hsConFieldSpecGeneralize,
FieldOcc(..), LFieldOcc,
@@ -67,7 +68,7 @@ module Language.Haskell.Syntax.Type (
import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice )
-import Language.Haskell.Syntax.Basic ( HsBang(..) )
+import Language.Haskell.Syntax.Basic ( HsBang(..), SrcStrictness, SrcUnpackedness )
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Specificity
@@ -983,13 +984,10 @@ type family XXMultAnnOn (on :: HsMultAnnOnWhat) mult p
data HsScaled on pass a = HsScaled (HsMultAnnOn on (LHsType pass) pass) a
deriving (Functor)
-hsScaledGeneralize :: HsScaled on pass a -> HsScaled on1 pass a
-hsScaledGeneralize = unsafeCoerce
-
-hsMultIsLinear :: Bool -> HsScaled on pass a -> Bool
-hsMultIsLinear _ (HsScaled (HsUnannotated HsUnannOne _) _) = True
-hsMultIsLinear linear (HsScaled (HsUnannotated HsUnannMany _) _) = not linear
-hsMultIsLinear _ (HsScaled HsLinearAnn{} _) = True
+hsMultIsLinear :: Bool -> HsMultAnnOn on mult pass -> Bool
+hsMultIsLinear _ (HsUnannotated HsUnannOne _) = True
+hsMultIsLinear linear (HsUnannotated HsUnannMany _) = not linear
+hsMultIsLinear _ HsLinearAnn{} = True
hsMultIsLinear _ _ = False
hsScaledThing :: HsScaled on pass a -> a
@@ -1098,7 +1096,7 @@ data ConDeclField pass -- Record fields have Haddock docs on them
= ConDeclField { cd_fld_ext :: XConDeclField pass,
cd_fld_names :: [LFieldOcc pass],
-- ^ See Note [ConDeclField pass]
- cd_fld_type :: HsScaled OnRecField pass (LBangType pass),
+ cd_fld_spec :: HsConFieldSpec OnRecField pass,
cd_fld_doc :: Maybe (LHsDoc pass)}
| XConDeclField !(XXConDeclField pass)
@@ -1129,6 +1127,16 @@ data HsConDetails tyarg arg rec
noTypeArgs :: [Void]
noTypeArgs = []
+data HsConFieldSpec on pass
+ = CFS { cfs_ext :: XConFieldSpec pass
+ , cfs_unpack :: SrcUnpackedness
+ , cfs_bang :: SrcStrictness
+ , cfs_multiplicity :: HsMultAnnOn on (LHsType pass) pass
+ , cfs_type :: LHsType pass }
+
+hsConFieldSpecGeneralize :: HsConFieldSpec on pass -> HsConFieldSpec on1 pass
+hsConFieldSpecGeneralize = unsafeCoerce
+
{-
Note [ConDeclField pass]
~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -4448,13 +4448,29 @@ instance (ExactPrint a) => ExactPrint (HsScaled OnArrow GhcPs a) where
arr' <- markArrow arr
return (HsScaled arr' t')
-instance (ExactPrint a) => ExactPrint (HsScaled OnRecField GhcPs a) where
+-- instance (ExactPrint a) => ExactPrint (HsScaled OnRecField GhcPs a) where
+-- getAnnotationEntry = const NoEntryVal
+-- setAnnotationAnchor a _ _ _ = a
+-- exact (HsScaled mult t) = do
+-- mult' <- markRecFieldMult mult
+-- t' <- markAnnotated t
+-- return (HsScaled mult' t')
+
+instance ExactPrint (HsConFieldSpec OnArrow GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (HsScaled mult t) = do
+ exact (CFS an unp str arr t) = do
+ t' <- markAnnotated t
+ arr' <- markArrow arr
+ return (CFS an unp str arr' t')
+
+instance ExactPrint (HsConFieldSpec OnRecField GhcPs) where
+ getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ _ = a
+ exact (CFS an unp str mult t) = do
mult' <- markRecFieldMult mult
t' <- markAnnotated t
- return (HsScaled mult' t')
+ return (CFS an unp str mult' t')
-- ---------------------------------------------------------------------
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
=====================================
@@ -295,14 +295,14 @@ ppCtor sDocContext dat subdocs con at ConDeclH98{con_args = con_args'} =
-- AZ:TODO get rid of the concatMap
concatMap (lookupCon sDocContext subdocs) [con_name con] ++ f con_args'
where
- f :: HsConDetails v (HsScaled on GhcRn (LHsType GhcRn)) (LocatedL [LocatedA (ConDeclField GhcRn)]) -> [String]
- f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
+ f :: HsConDetails v (HsConFieldSpec on GhcRn) (LocatedL [LocatedA (ConDeclField GhcRn)]) -> [String]
+ f (PrefixCon _ args) = [typeSig name $ (map cfs_type args) ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [] [a1, a2]
f (RecCon (L _ recs)) =
- f (PrefixCon [] $ map (cd_fld_type . unLoc) recs)
+ f (PrefixCon [] $ map (cd_fld_spec . unLoc) recs)
++ concat
[ (concatMap (lookupCon sDocContext subdocs . noLocA . unLoc . foLabel . unLoc) (cd_fld_names r))
- ++ [out sDocContext (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, hsScaledThing $ cd_fld_type r]]
+ ++ [out sDocContext (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cfs_type $ cd_fld_spec r]]
| r <- map unLoc recs
]
@@ -356,8 +356,8 @@ ppCtor
Nothing -> tau_ty
tau_ty = foldr mkFunTy res_ty $
case args of
- PrefixConGADT _ pos_args -> map hsScaledThing pos_args
- RecConGADT _ (L _ flds) -> map (hsScaledThing . cd_fld_type . unL) flds
+ PrefixConGADT _ pos_args -> map cfs_type pos_args
+ RecConGADT _ (L _ flds) -> map (cfs_type . cd_fld_spec . unL) flds
mkFunTy a b = noLocA (HsFunTy noExtField (HsUnrestrictedArrow noExtField) a b)
ppFixity :: SDocContext -> (Name, Fixity) -> [String]
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
=====================================
@@ -964,7 +964,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
hsep
[ header_
, ppOcc
- , hsep (map (ppLParendType unicode . hsScaledThing) args)
+ , hsep (map (ppLParendType unicode . cfs_type) args)
]
-- Record constructor, e.g. 'Identity { runIdentity :: a }'
RecCon _ -> header_ <+> ppOcc
@@ -974,9 +974,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
| otherwise ->
hsep
[ header_
- , ppLParendType unicode (hsScaledThing arg1)
+ , ppLParendType unicode (cfs_type arg1)
, ppOccInfix
- , ppLParendType unicode (hsScaledThing arg2)
+ , ppLParendType unicode (cfs_type arg2)
]
ConDeclGADT{}
| hasArgDocs || not (isEmpty fieldPart) -> ppOcc
@@ -993,15 +993,15 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
-- GADT record declarations
RecConGADT _ _ -> doConstrArgsWithDocs []
-- GADT prefix data constructors
- PrefixConGADT _ args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
+ PrefixConGADT _ args | hasArgDocs -> doConstrArgsWithDocs (map cfs_type args)
_ -> empty
ConDeclH98{con_args = con_args'} -> case con_args' of
-- H98 record declarations
RecCon (L _ fields) -> doRecordFields fields
-- H98 prefix data constructors
- PrefixCon _ args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
+ PrefixCon _ args | hasArgDocs -> doConstrArgsWithDocs (map cfs_type args)
-- H98 infix data constructor
- InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1, arg2])
+ InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map cfs_type [arg1, arg2])
_ -> empty
doRecordFields fields =
@@ -1035,7 +1035,7 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
decltt
( cat (punctuate comma (map (ppBinder . rdrNameOcc . foExt . unLoc) names))
<+> ppRecFieldMultAnn unicode ltype (dcolon unicode)
- <+> ppLType unicode (hsScaledThing ltype)
+ <+> ppLType unicode (cfs_type ltype)
)
<-> rDoc mbDoc
where
@@ -1047,8 +1047,8 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
Just hd -> hd
-ppRecFieldMultAnn :: Bool -> HsScaled on DocNameI a -> LaTeX -> LaTeX
-ppRecFieldMultAnn unicode (HsScaled arr _) following = case arr of
+ppRecFieldMultAnn :: Bool -> HsConFieldSpec on DocNameI -> LaTeX -> LaTeX
+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
=====================================
@@ -1350,7 +1350,7 @@ ppShortConstrParts summary dataInst con unicode qual =
in case det of
-- Prefix constructor, e.g. 'Just a'
PrefixCon _ args ->
- ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)
+ ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . cfs_type) args)
, noHtml
, noHtml
)
@@ -1368,9 +1368,9 @@ ppShortConstrParts summary dataInst con unicode qual =
InfixCon arg1 arg2 ->
( header_
<+> hsep
- [ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1)
+ [ ppLParendType unicode qual HideEmptyContexts (cfs_type arg1)
, ppOccInfix
- , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2)
+ , ppLParendType unicode qual HideEmptyContexts (cfs_type arg2)
]
, noHtml
, noHtml
@@ -1431,7 +1431,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) =
| otherwise ->
hsep
[ header_ <+> ppOcc
- , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)
+ , hsep (map (ppLParendType unicode qual HideEmptyContexts . cfs_type) args)
, fixity
]
-- Record constructor, e.g. 'Identity { runIdentity :: a }'
@@ -1441,9 +1441,9 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) =
| hasArgDocs -> header_ <+> ppOcc <+> fixity
| otherwise ->
hsep
- [ header_ <+> ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1)
+ [ header_ <+> ppLParendType unicode qual HideEmptyContexts (cfs_type arg1)
, ppOccInfix
- , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2)
+ , ppLParendType unicode qual HideEmptyContexts (cfs_type arg2)
, fixity
]
-- GADT constructor, e.g. 'Foo :: Int -> Foo'
@@ -1483,7 +1483,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) =
doConstrArgsWithDocs args = subFields pkg qual $ case con of
ConDeclH98{} ->
[ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, [])
- | (i, arg) <- zip [0 ..] (map hsScaledThing args)
+ | (i, arg) <- zip [0 ..] (map cfs_type args)
, let mdoc = Map.lookup i argDocs
]
ConDeclGADT{} ->
@@ -1543,7 +1543,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
]
)
<+> ppRecFieldMultAnn unicode qual ltype (dcolon unicode)
- <+> ppLType unicode qual HideEmptyContexts (hsScaledThing ltype)
+ <+> ppLType unicode qual HideEmptyContexts (cfs_type ltype)
, mbDoc
, []
)
@@ -1555,8 +1555,8 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
Just hd -> hd
-ppRecFieldMultAnn :: Unicode -> Qualification -> HsScaled on DocNameI a -> Html -> Html
-ppRecFieldMultAnn unicode qual (HsScaled arr _) following = case arr of
+ppRecFieldMultAnn :: Unicode -> Qualification -> HsConFieldSpec on DocNameI -> Html -> Html
+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
@@ -1565,7 +1565,7 @@ ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Htm
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 (hsScaledThing ltype)
+ <+> ppLType unicode qual HideEmptyContexts (cfs_type ltype)
-- | Pretty print an expanded pattern (for bundled patterns)
ppSideBySidePat
=====================================
utils/haddock/haddock-api/src/Haddock/Convert.hs
=====================================
@@ -494,13 +494,10 @@ synifyDataCon use_gadt_syntax dc =
linear_tys =
zipWith
- ( \(Scaled mult ty) bang ->
+ ( \(Scaled mult ty) (HsSrcBang st (HsBang unp str)) ->
let tySyn = synifyType WithinType [] ty
multSyn = synifyMultRec [] mult
- bangTy = case bang of
- (HsSrcBang _ (HsBang NoSrcUnpack NoSrcStrict)) -> tySyn
- (HsSrcBang src bang') -> noLocA $ HsBangTy (noAnn, src) bang' tySyn
- in HsScaled multSyn bangTy
+ in CFS (noAnn, st) unp str multSyn tySyn
)
arg_tys
(dataConSrcBangs dc)
@@ -518,15 +515,15 @@ synifyDataCon use_gadt_syntax dc =
mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
(True, True) -> Left "synifyDataCon: contradiction!"
(True, False) -> return $ RecCon (noLocA field_tys)
- (False, False) -> return $ PrefixCon noTypeArgs (map hsScaledGeneralize linear_tys)
- (False, True) -> case map hsScaledGeneralize linear_tys of
+ (False, False) -> return $ PrefixCon noTypeArgs (map hsConFieldSpecGeneralize linear_tys)
+ (False, True) -> case map hsConFieldSpecGeneralize linear_tys of
[a, b] -> return $ InfixCon a b
_ -> Left "synifyDataCon: infix with non-2 args?"
mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn
mk_gadt_arg_tys
| use_named_field_syntax = RecConGADT noExtField (noLocA field_tys)
- | otherwise = PrefixConGADT noExtField (map hsScaledGeneralize linear_tys)
+ | otherwise = PrefixConGADT noExtField (map hsConFieldSpecGeneralize linear_tys)
in
-- finally we get synifyDataCon's result!
if use_gadt_syntax
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -220,7 +220,7 @@ getGADTConType
-- tau_ty :: LHsType DocNameI
tau_ty = case args of
RecConGADT _ flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty
- PrefixConGADT _ pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
+ PrefixConGADT _ pos_args -> foldr mkFunTy res_ty (map cfs_type pos_args)
mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noExtField) a b)
@@ -361,8 +361,8 @@ restrictCons names decls = [L p d | L p (Just d) <- fmap keep <$> decls]
field_avail (L _ (ConDeclField _ fs _ _)) =
all (\f -> (unLoc . foLabel . unLoc $ f) `elem` names) fs
- field_types :: [LConDeclField GhcRn] -> [HsScaled OnArrow GhcRn (LBangType GhcRn)]
- field_types flds = [hsScaledGeneralize t | L _ (ConDeclField _ _ t _) <- flds]
+ field_types :: [LConDeclField GhcRn] -> [HsConFieldSpec OnArrow GhcRn]
+ field_types flds = [hsConFieldSpecGeneralize t | L _ (ConDeclField _ _ t _) <- flds]
keep _ = Nothing
restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]
@@ -513,7 +513,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 t d) = ConDeclField x n (fmap 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
=====================================
@@ -962,12 +962,12 @@ extractPatternSyn nm t tvs cons =
let args =
case con of
ConDeclH98{con_args = con_args'} -> case con_args' of
- PrefixCon _ args' -> map hsScaledThing args'
- RecCon (L _ fields) -> hsScaledThing . cd_fld_type . unLoc <$> fields
- InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
+ PrefixCon _ args' -> map cfs_type args'
+ RecCon (L _ fields) -> cfs_type . cd_fld_spec . unLoc <$> fields
+ InfixCon arg1 arg2 -> map cfs_type [arg1, arg2]
ConDeclGADT{con_g_args = con_args'} -> case con_args' of
- PrefixConGADT _ args' -> map hsScaledThing args'
- RecConGADT _ (L _ fields) -> hsScaledThing . cd_fld_type . unLoc <$> fields
+ PrefixConGADT _ args' -> map cfs_type args'
+ RecConGADT _ (L _ fields) -> cfs_type . cd_fld_spec . unLoc <$> fields
typ = longArrow args (data_ty con)
typ' =
case con of
@@ -999,7 +999,7 @@ extractRecSel nm t tvs (L _ con : rest) =
case getRecConArgs_maybe con of
Just (L _ 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 (getBangType $ hsScaledThing ty))))))
+ pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noExtField (HsUnrestrictedArrow noExtField) data_ty (cfs_type ty)))))) -- TODO : was getBangType $ hsScaledThing ty
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -718,10 +718,10 @@ renameCon
}
)
-renameHsScaled
- :: HsScaled on GhcRn (LHsType GhcRn)
- -> RnM (HsScaled on DocNameI (LHsType DocNameI))
-renameHsScaled (HsScaled w ty) = HsScaled <$> renameMultAnnOn w <*> renameLType ty
+renameHsConFieldSpec
+ :: HsConFieldSpec on GhcRn
+ -> RnM (HsConFieldSpec on DocNameI)
+renameHsConFieldSpec (CFS _ unp str w ty) = CFS noExtField unp str <$> renameMultAnnOn w <*> renameLType ty
renameH98Details
:: HsConDeclH98Details GhcRn
@@ -729,10 +729,10 @@ renameH98Details
renameH98Details (RecCon (L l fields)) = do
fields' <- mapM renameConDeclFieldField fields
return (RecCon (L (locA l) fields'))
-renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps
+renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsConFieldSpec ps
renameH98Details (InfixCon a b) = do
- a' <- renameHsScaled a
- b' <- renameHsScaled b
+ a' <- renameHsConFieldSpec a
+ b' <- renameHsConFieldSpec b
return (InfixCon a' b')
renameGADTDetails
@@ -741,12 +741,12 @@ renameGADTDetails
renameGADTDetails (RecConGADT _ (L l fields)) = do
fields' <- mapM renameConDeclFieldField fields
return (RecConGADT noExtField (L (locA l) fields'))
-renameGADTDetails (PrefixConGADT _ ps) = PrefixConGADT noExtField <$> mapM renameHsScaled ps
+renameGADTDetails (PrefixConGADT _ ps) = PrefixConGADT noExtField <$> mapM renameHsConFieldSpec ps
renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
names' <- mapM renameLFieldOcc names
- t' <- renameHsScaled t
+ t' <- renameHsConFieldSpec t
doc' <- mapM renameLDocHsSyn doc
return $ L (locA l) (ConDeclField noExtField names' t' doc')
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -964,6 +964,9 @@ type instance XXLHsQTyVars DocNameI = DataConCantHappen
type instance XConDeclField DocNameI = NoExtField
type instance XXConDeclField DocNameI = DataConCantHappen
+type instance XConFieldSpec DocNameI = NoExtField
+type instance XXConFieldSpec DocNameI = DataConCantHappen
+
type instance XXPat DocNameI = DataConCantHappen
type instance XXHsBindsLR DocNameI a = DataConCantHappen
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a28732e9c1d17a5f5c6b1f5d46513809fc11746a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a28732e9c1d17a5f5c6b1f5d46513809fc11746a
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/20250109/0ade594c/attachment-0001.html>
More information about the ghc-commits
mailing list