[Git][ghc/ghc][wip/T18462] Multiplicity annotation on records
Sjoerd Visscher (@trac-sjoerd_visscher)
gitlab at gitlab.haskell.org
Fri Nov 1 16:05:36 UTC 2024
Sjoerd Visscher pushed to branch wip/T18462 at Glasgow Haskell Compiler / GHC
Commits:
bd198fdb by Sjoerd Visscher at 2024-11-01T17:05:13+01:00
Multiplicity annotation on records
- - - - -
27 changed files:
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Type.hs
- + testsuite/tests/linear/should_compile/NonLinearRecord.hs
- testsuite/tests/linear/should_compile/all.T
- + testsuite/tests/linear/should_fail/LinearRecFieldMany.hs
- + testsuite/tests/linear/should_fail/LinearRecFieldMany.stderr
- testsuite/tests/linear/should_fail/all.T
- 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
Changes:
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -24,10 +24,10 @@ GHC.Hs.Type: Abstract syntax: user-defined types
module GHC.Hs.Type (
Mult, HsScaled(..),
- hsMult, hsScaledThing,
- HsArrow, HsArrowOf(..), arrowToHsType, expandHsArrow,
+ hsMultIsLinear, hsScaledThing, hsScaledToHsTypes,
+ HsArrow, HsArrowOf(..), HsUnrestrictedArrowUse(..), arrowToHsType, expandHsArrow,
EpLinearArrow(..),
- hsLinear, hsUnrestricted, isUnrestricted,
+ hsLinear, hsUnrestricted, hsNoMultAnn, isUnrestricted,
pprHsArrow,
HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,
@@ -539,13 +539,19 @@ hsLinear = HsScaled (HsLinearArrow x)
GhcTc -> noExtField
hsUnrestricted :: forall p a. IsPass p => a -> HsScaled (GhcPass p) a
-hsUnrestricted = HsScaled (HsUnrestrictedArrow x)
+hsUnrestricted = hsNoMultAnn HsArrowUseOther
+
+hsNoMultAnn :: forall p a. IsPass p => HsUnrestrictedArrowUse -> a -> HsScaled (GhcPass p) a
+hsNoMultAnn t = HsScaled (HsUnrestrictedArrow t x)
where
x = case ghcPass @p of
GhcPs -> noAnn
GhcRn -> noExtField
GhcTc -> noExtField
+hsScaledToHsTypes :: (a -> LHsType GhcRn) -> HsScaled GhcRn a -> [LHsType GhcRn]
+hsScaledToHsTypes f (HsScaled arr x) = [arrowToHsType arr, f x]
+
isUnrestricted :: HsArrow GhcRn -> Bool
isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName
isUnrestricted _ = False
@@ -557,7 +563,8 @@ arrowToHsType = expandHsArrow (HsTyVar noAnn NotPromoted)
-- erases the information of whether the programmer wrote an explicit
-- multiplicity or a shorthand.
expandHsArrow :: (LocatedN Name -> t GhcRn) -> HsArrowOf (LocatedA (t GhcRn)) GhcRn -> LocatedA (t GhcRn)
-expandHsArrow mk_var (HsUnrestrictedArrow _) = noLocA (mk_var (noLocA manyDataConName))
+expandHsArrow mk_var (HsUnrestrictedArrow HsRecFieldAnn _) = noLocA (mk_var (noLocA oneDataConName))
+expandHsArrow mk_var (HsUnrestrictedArrow _ _) = noLocA (mk_var (noLocA manyDataConName))
expandHsArrow mk_var (HsLinearArrow _) = noLocA (mk_var (noLocA oneDataConName))
expandHsArrow _mk_var (HsExplicitMult _ p) = p
@@ -568,7 +575,7 @@ instance
-- See #18846
pprHsArrow :: (Outputable mult, OutputableBndrId pass) => HsArrowOf mult (GhcPass pass) -> SDoc
-pprHsArrow (HsUnrestrictedArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left False)
+pprHsArrow (HsUnrestrictedArrow _ _) = pprArrowWithMultiplicity visArgTypeLike (Left False)
pprHsArrow (HsLinearArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left True)
pprHsArrow (HsExplicitMult _ p) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p))
@@ -577,7 +584,16 @@ type instance XXConDeclField (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
=> Outputable (ConDeclField (GhcPass p)) where
- ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
+ ppr (ConDeclField _ fld_n (HsScaled fld_mult fld_ty) _) = ppr_names fld_n <+> ppr_mult <+> ppr fld_ty
+ 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
+ HsUnrestrictedArrow _ _ -> dcolon
+ HsLinearArrow _ -> text "%1" <+> dcolon
+ HsExplicitMult _ p -> text "%" <> ppr p <+> dcolon
---------------------
hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]
@@ -1359,13 +1375,9 @@ pprConDeclFields :: forall p. OutputableBndrId p
=> [LConDeclField (GhcPass p)] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
- ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
- cd_fld_doc = doc }))
- = pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty)
-
- ppr_names :: forall p. OutputableBndrId p => [LFieldOcc (GhcPass p)] -> SDoc
- ppr_names [n] = pprPrefixOcc n
- ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns))
+ ppr_fld :: LConDeclField (GhcPass p) -> SDoc
+ ppr_fld (L _ (cdf at ConDeclField { cd_fld_doc = doc }))
+ = pprMaybeWithDoc doc (ppr cdf)
-- Printing works more-or-less as for Types
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -623,7 +623,7 @@ nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsAppTy f t = noLocA (HsAppTy noExtField f t)
nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA x))
-nlHsFunTy a b = noLocA (HsFunTy noExtField (HsUnrestrictedArrow x) a b)
+nlHsFunTy a b = noLocA (HsFunTy noExtField (HsUnrestrictedArrow HsArrowUseOther x) a b)
where
x = case ghcPass @p of
GhcPs -> noAnn
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -2870,10 +2870,7 @@ repGadtDataCons cons details res_ty
verifyLinearFields :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM ()
verifyLinearFields ps = do
linear <- lift $ xoptM LangExt.LinearTypes
- let allGood = all (\st -> case hsMult st of
- HsUnrestrictedArrow _ -> not linear
- HsLinearArrow _ -> True
- _ -> False) ps
+ let allGood = all (hsMultIsLinear linear) ps
unless allGood $ notHandled ThNonLinearDataCon
-- Desugar the arguments in a data constructor declared with prefix syntax.
@@ -2886,11 +2883,13 @@ repPrefixConArgs ps = do
-- Desugar the arguments in a data constructor declared with record syntax.
repRecConArgs :: LocatedL [LConDeclField GhcRn]
-> MetaM (Core [M TH.VarBangType])
-repRecConArgs ips = do
- args <- concatMapM rep_ip (unLoc ips)
+repRecConArgs lips = do
+ let ips = map unLoc (unLoc lips)
+ verifyLinearFields (map cd_fld_type ips)
+ args <- concatMapM rep_ip ips
coreListM varBangTypeTyConName args
where
- rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
+ rep_ip ip = mapM (rep_one_ip (hsScaledThing $ cd_fld_type ip)) (cd_fld_names ip)
rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
rep_one_ip t n = do { MkC v <- lookupOcc (unLoc . foLabel $ unLoc n)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -2000,7 +2000,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 typ)) fields
+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ getHasLoc $ hsScaledThing typ)) fields
, toHie typ
, toHie doc
]
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2260,7 +2260,7 @@ type :: { LHsType GhcPs }
-- See Note [%shift: type -> btype]
: btype %shift { $1 }
| btype '->' ctype {% amsA' (sLL $1 $>
- $ HsFunTy noExtField (HsUnrestrictedArrow (epUniTok $2)) $1 $3) }
+ $ HsFunTy noExtField (HsUnrestrictedArrow HsArrowUseOther (epUniTok $2)) $1 $3) }
| btype mult '->' ctype {% hintLinear (getLoc $2)
>> let arr = (unLoc $2) (epUniTok $3)
@@ -2597,7 +2597,12 @@ fielddecl :: { LConDeclField GhcPs }
{% amsA' (L (comb2 $1 $3)
(ConDeclField (epUniTok $2)
(reverse (map (\ln@(L l n)
- -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1))) $3 Nothing))}
+ -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1))) (hsNoMultAnn HsRecFieldAnn $3) Nothing))}
+ | sig_vars PREFIX_PERCENT atype '::' ctype
+ {% amsA' (L (comb4 $1 $2 $3 $5)
+ (ConDeclField (epUniTok $4)
+ (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))}
-- Reversed!
maybe_derivings :: { Located (HsDeriving GhcPs) }
@@ -2661,7 +2666,7 @@ There's an awkward overlap with a type signature. Consider
decl_no_th :: { LHsDecl GhcPs }
: sigdecl { $1 }
- | infixexp opt_sig rhs {% runPV (unECP $1) >>= \ $1 ->
+ | infixexp opt_sig rhs {% runPV (unECP $1) >>= \ $1 ->
do { let { l = comb2 $1 $> }
; r <- checkValDef l $1 (HsNoMultAnn noExtField, $2) $3;
-- Depending upon what the pattern looks like we might get either
@@ -2669,7 +2674,7 @@ decl_no_th :: { LHsDecl GhcPs }
-- [FunBind vs PatBind]
; !cs <- getCommentsFor l
; return $! (sL (commentsA l cs) $ ValD noExtField r) } }
- | PREFIX_PERCENT atype infixexp opt_sig rhs {% runPV (unECP $3) >>= \ $3 ->
+ | PREFIX_PERCENT atype infixexp opt_sig rhs {% runPV (unECP $3) >>= \ $3 ->
do { let { l = comb2 $1 $> }
; r <- checkValDef l $3 (mkMultAnn (epTok $1) $2, $4) $5;
-- parses bindings of the form %p x or
@@ -2855,7 +2860,7 @@ infixexp2 :: { ECP }
withArrowParsingMode' $ \mode ->
unECP $1 >>= \ $1 ->
unECP $3 >>= \ $3 ->
- let arr = HsUnrestrictedArrow (epUniTok $2)
+ let arr = HsUnrestrictedArrow HsArrowUseOther (epUniTok $2)
in mkHsArrowPV (comb2 $1 $>) mode $1 arr $3 }
| infixexp expmult '->' infixexp2
{ ECP $
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -71,6 +71,7 @@ module GHC.Parser.PostProcess (
UnpackednessPragma(..),
mkMultTy,
mkMultAnn,
+ mkMultField,
-- Token location
mkTokenLocation,
@@ -805,7 +806,7 @@ mkGadtDecl loc names dcol ty = do
case body_ty of
L ll (HsFunTy _ hsArr (L (EpAnn anc _ cs) (HsRecTy an rf)) res_ty) -> do
arr <- case hsArr of
- HsUnrestrictedArrow arr -> return arr
+ HsUnrestrictedArrow _ arr -> return arr
_ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $
(PsErrIllegalGadtRecordMultiplicity hsArr)
return noAnn
@@ -2071,7 +2072,7 @@ instance DisambECP (PatBuilder GhcPs) where
where
tok :: TokRarrow
tok = case arr of
- HsUnrestrictedArrow x -> x
+ HsUnrestrictedArrow _ x -> x
_ -> -- unreachable case because in Parser.y the reduction rules for
-- (a %m -> b) and (a ->. b) use ArrowIsFunType
panic "mkHsArrowPV ArrowIsViewPat: expected HsUnrestrictedArrow"
@@ -3518,6 +3519,9 @@ 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 GhcPs (LBangType GhcPs)
+mkMultField pct mult (EpUniTok l u) t = HsScaled (mkMultTy pct mult (EpUniTok l u)) t
+
mkTokenLocation :: SrcSpan -> TokenLocation
mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc
mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan (RealSrcSpan r mb))
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -451,10 +451,14 @@ rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
rnScaledLHsType :: HsDocContext -> HsScaled GhcPs (LHsType GhcPs)
- -> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
-rnScaledLHsType doc (HsScaled w ty) = do
- (w' , fvs_w) <- rnHsArrow (mkTyKiEnv doc TypeLevel RnTypeBody) w
- (ty', fvs) <- rnLHsType doc ty
+ -> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
+rnScaledLHsType doc = rnScaledLHsTyKi (mkTyKiEnv doc TypeLevel RnTypeBody)
+
+rnScaledLHsTyKi :: RnTyKiEnv -> HsScaled GhcPs (LHsType GhcPs)
+ -> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
+rnScaledLHsTyKi env (HsScaled w ty) = do
+ (w' , fvs_w) <- rnHsArrow env w
+ (ty', fvs) <- rnLHsTyKi env ty
return (HsScaled w' ty', fvs `plusFV` fvs_w)
@@ -709,7 +713,7 @@ rnHsArrow env = rnHsArrowWith (rnLHsTyKi env)
rnHsArrowWith :: (LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars))
-> HsArrowOf (LocatedA (mult GhcPs)) GhcPs
-> RnM (HsArrowOf (LocatedA (mult GhcRn)) GhcRn, FreeVars)
-rnHsArrowWith _rn (HsUnrestrictedArrow _) = pure (HsUnrestrictedArrow noExtField, emptyFVs)
+rnHsArrowWith _rn (HsUnrestrictedArrow arrUse _) = pure (HsUnrestrictedArrow arrUse noExtField, emptyFVs)
rnHsArrowWith _rn (HsLinearArrow _) = pure (HsLinearArrow noExtField, emptyFVs)
rnHsArrowWith rn (HsExplicitMult _ p)
= (\(mult, fvs) -> (HsExplicitMult noExtField mult, fvs)) <$> rn p
@@ -1334,7 +1338,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) <- rnLHsTyKi env ty
+ ; (new_ty, fvs) <- rnScaledLHsTyKi env ty
; haddock_doc' <- traverse rnLHsDoc haddock_doc
; return (L l (ConDeclField noAnn new_names new_ty haddock_doc')
, fvs) }
@@ -2030,7 +2034,7 @@ extractConDeclGADTDetailsTyVars ::
HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars
extractConDeclGADTDetailsTyVars con_args = case con_args of
PrefixConGADT _ args -> extract_scaled_ltys args
- RecConGADT _ (L _ flds) -> extract_ltys $ map (cd_fld_type . unLoc) $ flds
+ RecConGADT _ (L _ flds) -> extract_scaled_ltys $ map (cd_fld_type . unLoc) $ flds
-- | Get type/kind variables mentioned in the kind signature, preserving
-- left-to-right order:
@@ -2062,7 +2066,7 @@ extract_lty (L _ ty) acc
= case ty of
HsTyVar _ _ ltv -> extract_tv ltv acc
HsBangTy _ _ ty -> extract_lty ty acc
- HsRecTy _ flds -> foldr (extract_lty
+ HsRecTy _ flds -> foldr (extract_scaled_lty
. cd_fld_type . unLoc) acc
flds
HsAppTy _ ty1 ty2 -> extract_lty ty1 $
@@ -2119,6 +2123,10 @@ extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->
extract_hs_arrow (HsExplicitMult _ p) acc = extract_lty p acc
extract_hs_arrow _ acc = acc
+extract_hs_mult_ann :: HsMultAnn GhcPs -> FreeKiTyVars -> FreeKiTyVars
+extract_hs_mult_ann (HsMultAnn _ p) acc = extract_lty p acc
+extract_hs_mult_ann _ acc = acc
+
extract_hs_for_all_telescope :: HsForAllTelescope GhcPs
-> FreeKiTyVars -- Accumulator
-> FreeKiTyVars -- Free in body
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -1432,7 +1432,7 @@ rn_ty_pat ty@(XHsType{}) = do
liftRnFV $ rnHsType ctxt ty
rn_ty_pat_arrow :: HsArrow GhcPs -> TPRnM (HsArrow GhcRn)
-rn_ty_pat_arrow (HsUnrestrictedArrow _) = pure (HsUnrestrictedArrow noExtField)
+rn_ty_pat_arrow (HsUnrestrictedArrow arrUse _) = pure (HsUnrestrictedArrow arrUse noExtField)
rn_ty_pat_arrow (HsLinearArrow _) = pure (HsLinearArrow noExtField)
rn_ty_pat_arrow (HsExplicitMult _ p)
= rn_lty_pat p <&> (\mult -> HsExplicitMult noExtField mult)
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -985,7 +985,7 @@ expr_to_type earg =
; return (L l (HsFunTy noExtField mult' arg' res'))}
where
go_arrow :: HsArrowOf (LHsExpr GhcRn) GhcRn -> TcM (HsArrow GhcRn)
- go_arrow (HsUnrestrictedArrow{}) = pure (HsUnrestrictedArrow noExtField)
+ go_arrow (HsUnrestrictedArrow arrUse _) = pure (HsUnrestrictedArrow arrUse noExtField)
go_arrow (HsLinearArrow{}) = pure (HsLinearArrow noExtField)
go_arrow (HsExplicitMult _ exp) = HsExplicitMult noExtField <$> go exp
go (L l (HsForAll _ tele expr)) =
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1126,7 +1126,7 @@ tcHsType mode (HsFunTy _ mult ty1 ty2) exp_kind
tcHsType mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind
| op `hasKey` unrestrictedFunTyConKey
- = tc_fun_type mode (HsUnrestrictedArrow noExtField) ty1 ty2 exp_kind
+ = tc_fun_type mode (HsUnrestrictedArrow HsArrowUseOther noExtField) ty1 ty2 exp_kind
--------- Foralls
tcHsType mode t@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind
=====================================
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 $ map (cd_fld_type . unLoc) flds
+ HsRecTy _ flds -> gos $ concatMap (hsScaledToHsTypes id . cd_fld_type . unLoc) flds
HsExplicitListTy _ _ tys -> gos tys
HsExplicitTupleTy _ tys -> gos tys
HsForAllTy { hst_tele = tele
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -1801,11 +1801,11 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc
-- the first two arguments.
kcConArgTys :: NewOrData -> TcKind -> [HsScaled GhcRn (LHsType 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)
+ let exp_kind = getArgExpKind new_or_data res_kind
+ forM_ arg_tys $
+ \case
+ HsScaled mult ty -> tcCheckLHsTypeInContext (getBangType ty) exp_kind >> tcMult mult
-- See Note [Implementation of UnliftedNewtypes], STEP 2
- }
-- Kind-check the types of arguments to a Haskell98 data constructor.
kcConH98Args :: NewOrData -> TcKind -> HsConDeclH98Details GhcRn -> TcM ()
@@ -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 (hsLinear . cd_fld_type . unLoc) flds
+ map (cd_fld_type . 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 (hsLinear . cd_fld_type . unLoc) flds
+ map (cd_fld_type . unLoc) flds
kcConDecls :: Foldable f
=> NewOrData
@@ -3939,14 +3939,14 @@ 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,hsLinear (cd_fld_type f)))
+ combined = map (\(L _ f) -> (cd_fld_names f, cd_fld_type f))
(unLoc fields)
explode (ns,ty) = zip ns (repeat ty)
exploded = concatMap explode combined
(_,btys) = unzip exploded
tcDataConMult :: HsArrow GhcRn -> TcM Mult
-tcDataConMult arr@(HsUnrestrictedArrow _) = do
+tcDataConMult arr@(HsUnrestrictedArrow HsArrowUseOther _) = do
-- See Note [Function arrows in GADT constructors]
linearEnabled <- xoptM LangExt.LinearTypes
if linearEnabled then tcMult arr else return oneDataConTy
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -792,7 +792,7 @@ cvt_id_arg parent_con (i, str, ty)
{ cd_fld_ext = noAnn
, cd_fld_names
= [L (l2l li) $ FieldOcc noExtField (L li i')]
- , cd_fld_type = ty'
+ , cd_fld_type = hsNoMultAnn HsRecFieldAnn ty'
, cd_fld_doc = Nothing} }
cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
@@ -1690,7 +1690,7 @@ cvtTypeKind typeOrKind ty
_ -> return $
parenthesizeHsType sigPrec x'
let y'' = parenthesizeHsType sigPrec y'
- returnLA (HsFunTy noExtField (HsUnrestrictedArrow noAnn) x'' y'')
+ returnLA (HsFunTy noExtField (HsUnrestrictedArrow HsArrowUseOther noAnn) x'' y'')
| otherwise
-> do { fun_tc <- returnLA $ getRdrName unrestrictedFunTyCon
; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' }
@@ -1857,7 +1857,7 @@ hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs
hsTypeToArrow w = case unLoc w of
HsTyVar _ _ (L _ (isExact_maybe -> Just n))
| n == oneDataConName -> HsLinearArrow noAnn
- | n == manyDataConName -> HsUnrestrictedArrow noAnn
+ | n == manyDataConName -> HsUnrestrictedArrow HsArrowUseOther noAnn
_ -> HsExplicitMult noAnn w
-- ConT/InfixT can contain both data constructor (i.e., promoted) names and
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -21,8 +21,9 @@ 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(..),
- hsMult, hsScaledThing,
- HsArrow, HsArrowOf(..), XUnrestrictedArrow, XLinearArrow, XExplicitMult, XXArrow,
+ hsMultIsLinear, hsScaledThing,
+ HsArrow, HsArrowOf(..), HsUnrestrictedArrowUse(..),
+ XUnrestrictedArrow, XLinearArrow, XExplicitMult, XXArrow,
HsType(..), LHsType, HsKind, LHsKind,
HsBndrVis(..), XBndrRequired, XBndrInvisible, XXBndrVis,
@@ -78,7 +79,7 @@ import Data.Maybe
import Data.Eq
import Data.Bool
import Data.Char
-import Prelude (Integer)
+import Prelude (Integer, Functor)
import Data.Ord (Ord)
{-
@@ -938,9 +939,12 @@ data HsTyLit pass
type HsArrow pass = HsArrowOf (LHsType pass) pass
+data HsUnrestrictedArrowUse = HsRecFieldAnn | HsArrowUseOther
+ deriving (Eq, Ord, Data)
+
-- | Denotes the type of arrows in the surface language
data HsArrowOf mult pass
- = HsUnrestrictedArrow !(XUnrestrictedArrow mult pass)
+ = HsUnrestrictedArrow HsUnrestrictedArrowUse !(XUnrestrictedArrow mult pass)
-- ^ a -> b or a → b
| HsLinearArrow !(XLinearArrow mult pass)
@@ -962,9 +966,13 @@ type family XXArrow mult p
-- | This is used in the syntax. In constructor declaration. It must keep the
-- arrow representation.
data HsScaled pass a = HsScaled (HsArrow pass) a
+ deriving (Functor)
-hsMult :: HsScaled pass a -> HsArrow pass
-hsMult (HsScaled m _) = m
+hsMultIsLinear :: Bool -> HsScaled pass a -> Bool
+hsMultIsLinear _ (HsScaled (HsUnrestrictedArrow HsRecFieldAnn _) _) = True
+hsMultIsLinear linear (HsScaled HsUnrestrictedArrow{} _) = not linear
+hsMultIsLinear _ (HsScaled HsLinearArrow{} _) = True
+hsMultIsLinear _ _ = False
hsScaledThing :: HsScaled pass a -> a
hsScaledThing (HsScaled _ t) = t
@@ -1072,7 +1080,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 :: LBangType pass,
+ cd_fld_type :: HsScaled pass (LBangType pass),
cd_fld_doc :: Maybe (LHsDoc pass)}
| XConDeclField !(XXConDeclField pass)
=====================================
testsuite/tests/linear/should_compile/NonLinearRecord.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE LinearTypes, DataKinds #-}
+module NonLinearRecord where
+
+import GHC.Exts (Multiplicity(..))
+
+data C = C { linC %1 :: Int, urC %'Many :: Char, noC :: Bool }
+
+data G where
+ G :: { linG %1 :: Int, urG %'Many :: Char, noG :: Bool } -> G
+
+testC :: Int %1 -> Char -> Bool %1 -> C
+testC x y z = C x y z
+
+testG :: Int %1 -> Char -> Bool %1 -> G
+testG x y z = G x y z
=====================================
testsuite/tests/linear/should_compile/all.T
=====================================
@@ -47,3 +47,4 @@ test('LinearLet', normal, compile, [''])
test('LinearLetPoly', normal, compile, [''])
test('LinearListComprehension', normal, compile, ['-dlinear-core-lint'])
test('OmitFieldPat', normal, compile, ['-dcore-lint'])
+test('NonLinearRecord', normal, compile, [''])
\ No newline at end of file
=====================================
testsuite/tests/linear/should_fail/LinearRecFieldMany.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE LinearTypes, DataKinds #-}
+module LinearRecFieldMany where
+
+import GHC.Exts (Multiplicity(..))
+
+data C = C { urC %'Many :: Int }
+
+test :: Int %1 -> C
+test = C
=====================================
testsuite/tests/linear/should_fail/LinearRecFieldMany.stderr
=====================================
@@ -0,0 +1,6 @@
+LinearRecFieldMany.hs:9:8: [GHC-83865]
+ Couldn't match type ‘Many’ with ‘One’
+ Expected: Int %1 -> C
+ Actual: Int -> C
+ In the expression: C
+ In an equation for ‘test’: test = C
=====================================
testsuite/tests/linear/should_fail/all.T
=====================================
@@ -34,6 +34,7 @@ test('LinearFFI', normal, compile_fail, [''])
test('LinearTHFail', normal, compile_fail, [''])
test('LinearTHFail2', normal, compile_fail, [''])
test('LinearTHFail3', normal, compile_fail, [''])
+test('LinearRecFieldMany', normal, compile_fail, [''])
test('T18888', normal, compile_fail, [''])
test('T18888_datakinds', normal, compile_fail, [''])
test('T19120', normal, compile_fail, [''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -4437,6 +4437,10 @@ instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where
t' <- markAnnotated t
arr' <- markArrow arr
return (HsScaled arr' t')
+ exact (HsRecFieldScaled mult t) = do
+ t' <- markAnnotated t
+ mult' <- exact mult
+ return (HsRecFieldScaled mult' t')
-- ---------------------------------------------------------------------
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
=====================================
@@ -298,14 +298,14 @@ ppCtor sDocContext dat subdocs con at ConDeclH98{con_args = con_args'} =
f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [] [a1, a2]
f (RecCon (L _ recs)) =
- f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs)
+ f (PrefixCon [] $ map (cd_fld_type . 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, cd_fld_type r]]
+ ++ [out sDocContext (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, hsScaledThing $ cd_fld_type r]]
| r <- map unLoc recs
]
- funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow noExtField) x y)
+ funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow HsArrowUseOther noExtField) x y)
apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
typeSig nm flds =
@@ -356,8 +356,8 @@ ppCtor
tau_ty = foldr mkFunTy res_ty $
case args of
PrefixConGADT _ pos_args -> map hsScaledThing pos_args
- RecConGADT _ (L _ flds) -> map (cd_fld_type . unL) flds
- mkFunTy a b = noLocA (HsFunTy noExtField (HsUnrestrictedArrow noExtField) a b)
+ RecConGADT _ (L _ flds) -> map (hsScaledThing . cd_fld_type . unL) flds
+ mkFunTy a b = noLocA (HsFunTy noExtField (HsUnrestrictedArrow HsArrowUseOther noExtField) a b)
ppFixity :: SDocContext -> (Name, Fixity) -> [String]
ppFixity sDocContext (name, fixity) = [out sDocContext ((FixitySig NoNamespaceSpecifier [noLocA name] fixity) :: FixitySig GhcRn)]
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
=====================================
@@ -1035,7 +1035,7 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
decltt
( cat (punctuate comma (map (ppBinder . rdrNameOcc . foExt . unLoc) names))
<+> dcolon unicode
- <+> ppLType unicode ltype
+ <+> ppLType unicode (hsScaledThing ltype)
)
<-> rDoc mbDoc
where
@@ -1312,7 +1312,7 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u =
where
arr = case mult of
HsLinearArrow _ -> lollipop u
- HsUnrestrictedArrow _ -> arrow u
+ HsUnrestrictedArrow _ _ -> arrow u
HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u
ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty
ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
=====================================
@@ -1543,7 +1543,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
]
)
<+> dcolon unicode
- <+> ppLType unicode qual HideEmptyContexts ltype
+ <+> ppLType unicode qual HideEmptyContexts (hsScaledThing ltype)
, mbDoc
, []
)
@@ -1559,7 +1559,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))
<+> dcolon unicode
- <+> ppLType unicode qual HideEmptyContexts ltype
+ <+> ppLType unicode qual HideEmptyContexts (hsScaledThing ltype)
-- | Pretty print an expanded pattern (for bundled patterns)
ppSideBySidePat
@@ -1817,7 +1817,7 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =
where
arr = case mult of
HsLinearArrow _ -> lollipop u
- HsUnrestrictedArrow _ -> arrow u
+ HsUnrestrictedArrow _ _ -> arrow u
HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
ppr_mono_ty (HsTupleTy _ con tys) u q _ =
tupleParens con (map (ppLType u q HideEmptyContexts) tys)
=====================================
utils/haddock/haddock-api/src/Haddock/Convert.hs
=====================================
@@ -506,8 +506,8 @@ synifyDataCon use_gadt_syntax dc =
noLocA $
ConDeclField
noAnn
- [noLocA $ FieldOcc (mkVarUnqual $ field_label $ flLabel fl) (noLocA (flSelector fl))]
- synTy
+ [noLocA $ FieldOcc (mkVarUnqual $ field_label $ flLabel fl) (noLocA (flSelector fl))]
+ (hsNoMultAnn HsRecFieldAnn synTy)
Nothing
mk_h98_arg_tys :: Either String (HsConDeclH98Details GhcRn)
@@ -987,7 +987,7 @@ noKindTyVars _ _ = emptyVarSet
synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn
synifyMult vs t = case t of
OneTy -> HsLinearArrow noExtField
- ManyTy -> HsUnrestrictedArrow noExtField
+ ManyTy -> HsUnrestrictedArrow HsArrowUseOther noExtField
ty -> HsExplicitMult noExtField (synifyType WithinType vs ty)
synifyPatSynType :: PatSyn -> LHsType GhcRn
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -223,7 +223,7 @@ getGADTConType
PrefixConGADT _ pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
- mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noExtField) a b)
+ mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow HsArrowUseOther noExtField) a b)
getGADTConType (ConDeclH98{}) = panic "getGADTConType"
-- Should only be called on ConDeclGADT
@@ -361,7 +361,7 @@ 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 flds = [hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds]
+ field_types flds = [t | L _ (ConDeclField _ _ t _) <- flds]
keep _ = Nothing
restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]
@@ -512,7 +512,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 (reparenLType t) d
+reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (fmap reparenLType t) d
reparenConDeclField c at XConDeclField{} = c
-------------------------------------------------------------------------------
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
=====================================
@@ -963,11 +963,11 @@ extractPatternSyn nm t tvs cons =
case con of
ConDeclH98{con_args = con_args'} -> case con_args' of
PrefixCon _ args' -> map hsScaledThing args'
- RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
+ RecCon (L _ fields) -> hsScaledThing . cd_fld_type . unLoc <$> fields
InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
ConDeclGADT{con_g_args = con_args'} -> case con_args' of
PrefixConGADT _ args' -> map hsScaledThing args'
- RecConGADT _ (L _ fields) -> cd_fld_type . unLoc <$> fields
+ RecConGADT _ (L _ fields) -> hsScaledThing . cd_fld_type . unLoc <$> fields
typ = longArrow args (data_ty con)
typ' =
case con of
@@ -977,7 +977,7 @@ extractPatternSyn nm t tvs cons =
in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'')
longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
- longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noExtField (HsUnrestrictedArrow noExtField) x y)) output inputs
+ longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noExtField (HsUnrestrictedArrow HsArrowUseOther noExtField) x y)) output inputs
data_ty con
| ConDeclGADT{} <- con = con_res_ty con
@@ -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 ty))))))
+ pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noExtField (HsUnrestrictedArrow HsArrowUseOther noExtField) data_ty (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
=====================================
@@ -338,7 +338,7 @@ renameMaybeInjectivityAnn
renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)
-renameArrow (HsUnrestrictedArrow _) = return (HsUnrestrictedArrow noExtField)
+renameArrow (HsUnrestrictedArrow _ _) = return (HsUnrestrictedArrow HsArrowUseOther noExtField)
renameArrow (HsLinearArrow _) = return (HsLinearArrow noExtField)
renameArrow (HsExplicitMult _ p) = HsExplicitMult noExtField <$> renameLType p
@@ -743,7 +743,7 @@ renameGADTDetails (PrefixConGADT _ ps) = PrefixConGADT noExtField <$> mapM renam
renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
names' <- mapM renameLFieldOcc names
- t' <- renameLType t
+ t' <- renameHsScaled t
doc' <- mapM renameLDocHsSyn doc
return $ L (locA l) (ConDeclField noExtField names' t' doc')
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bd198fdba1ed1d7820364b8f47d555970d696caf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bd198fdba1ed1d7820364b8f47d555970d696caf
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/20241101/fd65266c/attachment-0001.html>
More information about the ghc-commits
mailing list