[Git][ghc/ghc][wip/T18462] Multiplicity annotation on records
Sjoerd Visscher (@trac-sjoerd_visscher)
gitlab at gitlab.haskell.org
Thu Nov 7 13:49:55 UTC 2024
Sjoerd Visscher pushed to branch wip/T18462 at Glasgow Haskell Compiler / GHC
Commits:
07ccdec4 by Sjoerd Visscher at 2024-11-07T14:49:31+01:00
Multiplicity annotation on records
- - - - -
30 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/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/html-test/ref/LinearTypes.html
- utils/haddock/html-test/src/LinearTypes.hs
- utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
- utils/haddock/latex-test/src/LinearTypes/LinearTypes.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,16 +575,25 @@ instance
-- See #18846
pprHsArrow :: (Outputable mult, OutputableBndrId pass) => HsArrowOf mult (GhcPass pass) -> SDoc
-pprHsArrow (HsUnrestrictedArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left False)
-pprHsArrow (HsLinearArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left True)
-pprHsArrow (HsExplicitMult _ p) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p))
+pprHsArrow (HsUnrestrictedArrow _ _) = pprArrowWithMultiplicity visArgTypeLike (Left False)
+pprHsArrow (HsLinearArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left True)
+pprHsArrow (HsExplicitMult _ p) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p))
type instance XConDeclField (GhcPass _) = TokDcolon
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
=====================================
@@ -2865,15 +2865,10 @@ 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.
--- This check is not performed in repRecConArgs, since the GADT record
--- syntax currently does not have a way to mark fields as nonlinear.
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 +2881,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 _ t = HsScaled (mkMultTy pct mult noAnn) 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 $
=====================================
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
=====================================
@@ -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 HsArrowUseOther _) _) = 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 m = C { linC %1 :: Int, urC %Many :: Char, varC %m :: String, noC :: Bool }
+
+data G mult where
+ G :: { linG %1 :: Int, urG %Many :: Char, varG %m :: String, noG :: Bool } -> G m
+
+testC :: Int %1 -> Char -> String -> Bool %1 -> C Many
+testC w x y z = C w x y z
+
+testG :: Int %1 -> Char -> String %1 -> Bool %1 -> G One
+testG w x y z = G w 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/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
=====================================
@@ -1034,8 +1034,8 @@ ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField Doc
ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
decltt
( cat (punctuate comma (map (ppBinder . rdrNameOcc . foExt . unLoc) names))
- <+> dcolon unicode
- <+> ppLType unicode ltype
+ <+> ppRecFieldMultAnn unicode ltype (dcolon unicode)
+ <+> ppLType unicode (hsScaledThing ltype)
)
<-> rDoc mbDoc
where
@@ -1047,6 +1047,12 @@ 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 DocNameI a -> LaTeX -> LaTeX
+ppRecFieldMultAnn unicode (HsScaled arr _) following = case arr of
+ HsUnrestrictedArrow _ _ -> following
+ HsLinearArrow _ -> text "%1" <+> following
+ HsExplicitMult _ mult -> multAnnotation <> ppr_mono_lty mult unicode <+> following
+
-- | Pretty-print a bundled pattern synonym
ppSideBySidePat
:: [LocatedN DocName]
@@ -1312,7 +1318,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
=====================================
@@ -1542,8 +1542,8 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
, let field = (foExt) name
]
)
- <+> dcolon unicode
- <+> ppLType unicode qual HideEmptyContexts ltype
+ <+> ppRecFieldMultAnn unicode qual ltype (dcolon unicode)
+ <+> ppLType unicode qual HideEmptyContexts (hsScaledThing ltype)
, mbDoc
, []
)
@@ -1555,11 +1555,17 @@ 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 DocNameI a -> Html -> Html
+ppRecFieldMultAnn unicode qual (HsScaled arr _) following = case arr of
+ HsUnrestrictedArrow _ _ -> following
+ HsLinearArrow _ -> 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 _) =
hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . foExt . unLoc) names))
- <+> dcolon unicode
- <+> ppLType unicode qual HideEmptyContexts ltype
+ <+> ppRecFieldMultAnn unicode qual ltype (dcolon unicode)
+ <+> ppLType unicode qual HideEmptyContexts (hsScaledThing ltype)
-- | Pretty print an expanded pattern (for bundled patterns)
ppSideBySidePat
@@ -1817,7 +1823,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
=====================================
@@ -493,11 +493,13 @@ synifyDataCon use_gadt_syntax dc =
linear_tys =
zipWith
- ( \ty bang ->
- let tySyn = synifyType WithinType [] (scaledThing ty)
- in case bang of
+ ( \(Scaled mult ty) bang ->
+ 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
)
arg_tys
(dataConSrcBangs dc)
@@ -507,7 +509,7 @@ synifyDataCon use_gadt_syntax dc =
noLocA $
ConDeclField
noAnn
- [noLocA $ FieldOcc (mkVarUnqual $ field_label $ flLabel fl) (noLocA (flSelector fl))]
+ [noLocA $ FieldOcc (mkVarUnqual $ field_label $ flLabel fl) (noLocA (flSelector fl))]
synTy
Nothing
@@ -515,15 +517,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 hsUnrestricted linear_tys)
+ (False, False) -> return $ PrefixCon noTypeArgs linear_tys
(False, True) -> case linear_tys of
- [a, b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)
+ [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 hsUnrestricted linear_tys)
+ | otherwise = PrefixConGADT noExtField linear_tys
in
-- finally we get synifyDataCon's result!
if use_gadt_syntax
@@ -988,7 +990,12 @@ 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)
+
+synifyMultRec :: [TyVar] -> Mult -> HsArrow GhcRn
+synifyMultRec vs t = case t of
+ OneTy -> HsUnrestrictedArrow HsRecFieldAnn 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
=====================================
@@ -341,7 +341,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
@@ -746,7 +746,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')
=====================================
utils/haddock/html-test/ref/LinearTypes.html
=====================================
@@ -36,7 +36,7 @@
><th
>Safe Haskell</th
><td
- >Safe-Inferred</td
+ >None</td
></tr
><tr
><th
@@ -69,6 +69,66 @@
> a (m :: <a href="#" title="GHC.Exts"
>Multiplicity</a
>) b. a %m -> b</li
+ ><li class="src short"
+ ><span class="keyword"
+ >data</span
+ > <a href="#"
+ >C</a
+ > (m :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >) = <a href="#"
+ >C</a
+ > {<ul class="subs"
+ ><li
+ ><a href="#"
+ >linC</a
+ > :: <a href="#" title="Data.Int"
+ >Int</a
+ ></li
+ ><li
+ ><a href="#"
+ >urC</a
+ > %'<a href="#" title="GHC.Exts"
+ >Many</a
+ > :: <a href="#" title="Data.Char"
+ >Char</a
+ ></li
+ ><li
+ ><a href="#"
+ >varC</a
+ > %m :: <a href="#" title="Data.String"
+ >String</a
+ ></li
+ ><li
+ ><a href="#"
+ >noC</a
+ > :: <a href="#" title="Data.Bool"
+ >Bool</a
+ ></li
+ ></ul
+ >}</li
+ ><li class="src short"
+ ><span class="keyword"
+ >data</span
+ > <a href="#"
+ >G</a
+ > (mult :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >) <span class="keyword"
+ >where</span
+ ><ul class="subs"
+ ><li
+ ><a href="#"
+ >G</a
+ > :: <span class="keyword"
+ >forall</span
+ > (mult :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >). {..} -> <a href="#" title="LinearTypes"
+ >G</a
+ > mult</li
+ ></ul
+ ></li
></ul
></details
></div
@@ -115,6 +175,184 @@
>Does something polymorphic.</p
></div
></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >data</span
+ > <a id="t:C" class="def"
+ >C</a
+ > (m :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >) <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >A record with non-linear fields.</p
+ ></div
+ ><div class="subs constructors"
+ ><p class="caption"
+ >Constructors</p
+ ><table
+ ><tr
+ ><td class="src"
+ ><a id="v:C" class="def"
+ >C</a
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><div class="subs fields"
+ ><p class="caption"
+ >Fields</p
+ ><ul
+ ><li
+ ><dfn class="src"
+ ><a id="v:linC" class="def"
+ >linC</a
+ > :: <a href="#" title="Data.Int"
+ >Int</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ ><a id="v:urC" class="def"
+ >urC</a
+ > %'<a href="#" title="GHC.Exts"
+ >Many</a
+ > :: <a href="#" title="Data.Char"
+ >Char</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ ><a id="v:varC" class="def"
+ >varC</a
+ > %m :: <a href="#" title="Data.String"
+ >String</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ ><a id="v:noC" class="def"
+ >noC</a
+ > :: <a href="#" title="Data.Bool"
+ >Bool</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ></ul
+ ></div
+ ></td
+ ></tr
+ ></table
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >data</span
+ > <a id="t:G" class="def"
+ >G</a
+ > (mult :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >) <span class="keyword"
+ >where</span
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >A GADT record with non-linear fields.</p
+ ></div
+ ><div class="subs constructors"
+ ><p class="caption"
+ >Constructors</p
+ ><table
+ ><tr
+ ><td class="src"
+ ><a id="v:G" class="def"
+ >G</a
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><div class="subs fields"
+ ><p class="caption"
+ >Fields</p
+ ><ul
+ ><li
+ ><dfn class="src"
+ >:: <span class="keyword"
+ >forall</span
+ > (mult :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >). { <a id="v:linG" class="def"
+ >linG</a
+ > :: <a href="#" title="Data.Int"
+ >Int</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ > , <a id="v:urG" class="def"
+ >urG</a
+ > %'<a href="#" title="GHC.Exts"
+ >Many</a
+ > :: <a href="#" title="Data.Char"
+ >Char</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ > , <a id="v:varG" class="def"
+ >varG</a
+ > %mult :: <a href="#" title="Data.String"
+ >String</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ > , <a id="v:noG" class="def"
+ >noG</a
+ > :: <a href="#" title="Data.Bool"
+ >Bool</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ > } -> <a href="#" title="LinearTypes"
+ >G</a
+ > mult</dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ></ul
+ ></div
+ ></td
+ ></tr
+ ></table
+ ></div
+ ></div
></div
></div
></body
=====================================
utils/haddock/html-test/src/LinearTypes.hs
=====================================
@@ -1,7 +1,11 @@
{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
module LinearTypes where
+import GHC.Exts (Multiplicity(..))
+
-- | Does something unrestricted.
unrestricted :: a -> b
unrestricted = undefined
@@ -13,3 +17,10 @@ linear = linear
-- | Does something polymorphic.
poly :: a %m -> b
poly = poly
+
+-- | A record with non-linear fields.
+data C m = C { linC %1 :: Int, urC %Many :: Char, varC %m :: String, noC :: Bool }
+
+-- | A GADT record with non-linear fields.
+data G mult where
+ G :: { linG %1 :: Int, urG %Many :: Char, varG %m :: String, noG :: Bool } -> G m
=====================================
utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
=====================================
@@ -3,7 +3,8 @@
\haddockbeginheader
{\haddockverb\begin{verbatim}
module LinearTypes (
- unrestricted, linear, poly
+ unrestricted, linear, poly, C(C, linC, noC, urC, varC),
+ G(G, linG, noG, urG, varG)
) where\end{verbatim}}
\haddockendheader
@@ -27,4 +28,32 @@ poly :: forall a (m :: Multiplicity) b. a {\char '45}m -> b
\end{tabular}]
{\haddockbegindoc
Does something polymorphic.\par}
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+data C m
+\end{tabular}]
+{\haddockbegindoc
+A record with non-linear fields.\par
+\enspace \emph{Constructors}\par
+\haddockbeginconstrs
+\haddockdecltt{=} & \haddockdecltt{C} & \\
+ & \haddocktt{\qquad \{} \haddockdecltt{linC :: Int} & \\
+ & \haddocktt{\qquad ,} \haddockdecltt{urC {\char '45}'Many :: Char} & \\
+ & \haddocktt{\qquad ,} \haddockdecltt{varC {\char '45}m :: String} & \\
+ & \haddocktt{\qquad ,} \haddockdecltt{noC :: Bool} & \\ & \haddocktt{\qquad \}} \\
+\end{tabulary}\par}
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+data G mult where
+\end{tabular}]
+{\haddockbegindoc
+A GADT record with non-linear fields.\par
+\enspace \emph{Constructors}\par
+\haddockbeginconstrs
+& \haddockdecltt{G} & \\
+ & \qquad \haddockdecltt{::} \enspace \haddockdecltt{forall (mult :: Multiplicity).} {..}
+ -> G mult
+\end{tabulary}\par}
\end{haddockdesc}
\ No newline at end of file
=====================================
utils/haddock/latex-test/src/LinearTypes/LinearTypes.hs
=====================================
@@ -1,7 +1,11 @@
{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
module LinearTypes where
+import GHC.Exts (Multiplicity(..))
+
-- | Does something unrestricted.
unrestricted :: a -> b
unrestricted = undefined
@@ -13,3 +17,10 @@ linear = linear
-- | Does something polymorphic.
poly :: a %m -> b
poly = poly
+
+-- | A record with non-linear fields.
+data C m = C { linC %1 :: Int, urC %Many :: Char, varC %m :: String, noC :: Bool }
+
+-- | A GADT record with non-linear fields.
+data G mult where
+ G :: { linG %1 :: Int, urG %Many :: Char, varG %m :: String, noG :: Bool } -> G m
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/07ccdec4fc0a3d6f938314fa2cb33f49624b8519
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/07ccdec4fc0a3d6f938314fa2cb33f49624b8519
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/20241107/3bb8801f/attachment-0001.html>
More information about the ghc-commits
mailing list