[Git][ghc/ghc][wip/T18462] Unannotated multiplicity based on type
Sjoerd Visscher (@trac-sjoerd_visscher)
gitlab at gitlab.haskell.org
Thu Jan 23 15:51:42 UTC 2025
Sjoerd Visscher pushed to branch wip/T18462 at Glasgow Haskell Compiler / GHC
Commits:
1a49aa49 by Sjoerd Visscher at 2025-01-23T16:51:08+01:00
Unannotated multiplicity based on type
- - - - -
25 changed files:
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Type.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/TyCl.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Type.hs
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/printer/T18791.stderr
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
Changes:
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -539,11 +539,11 @@ deriving instance Data (HsTyLit GhcTc)
-- 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 Data (HsMultAnnOn OnConField (LocatedA (HsType GhcPs)) GhcPs)
deriving instance Typeable on => Data (HsMultAnnOn on (LocatedA (HsType GhcRn)) GhcRn)
deriving instance Typeable on => Data (HsMultAnnOn on (LocatedA (HsType GhcTc)) GhcTc)
deriving instance Data (HsMultAnnOn OnArrow (LocatedA (HsExpr GhcPs)) GhcPs)
-deriving instance Data (HsMultAnnOn OnRecField (LocatedA (HsExpr GhcPs)) GhcPs)
+deriving instance Data (HsMultAnnOn OnConField (LocatedA (HsExpr GhcPs)) GhcPs)
deriving instance Typeable on => Data (HsMultAnnOn on (LocatedA (HsExpr GhcRn)) GhcRn)
deriving instance Typeable on => Data (HsMultAnnOn on (LocatedA (HsExpr GhcTc)) GhcTc)
@@ -559,7 +559,7 @@ 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 Data (HsConFieldSpec OnConField GhcPs)
deriving instance Typeable on => Data (HsConFieldSpec on GhcRn)
deriving instance Typeable on => Data (HsConFieldSpec on GhcTc)
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -26,9 +26,9 @@ GHC.Hs.Type: Abstract syntax: user-defined types
module GHC.Hs.Type (
Mult,
HsArrow, HsArrowOf, HsMultAnnOn(..), HsMultAnnOnWhat(..),
- HsUnannotatedMult(..), pattern HsUnrestrictedArrow, multAnnToHsType, expandHsMultAnnOn,
+ pattern HsUnrestrictedArrow, multAnnToHsType, expandHsMultAnnOn,
EpLinearArrow(..),
- hsNoMultAnn, isUnrestricted, hsMultIsLinear,
+ hsNoMultAnn, isUnrestricted,
pprHsArrow,
HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,
@@ -129,7 +129,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Misc (count)
import Data.Maybe
-import Data.Data (Data)
+import Data.Data (Data, Proxy (..))
import qualified Data.Semigroup as S
import GHC.Data.Bag
@@ -531,39 +531,46 @@ instance NoAnn EpLinearArrow where
noAnn = EpPct1 noAnn noAnn
type instance XUnannotated OnArrow _ GhcPs = TokRarrow
-type instance XUnannotated OnRecField _ GhcPs = TokDcolon
+type instance XUnannotated OnConField _ GhcPs = TokDcolon
type instance XUnannotated _ _ GhcRn = NoExtField
type instance XUnannotated _ _ GhcTc = NoExtField
type instance XLinearAnn OnArrow _ GhcPs = EpLinearArrow
-type instance XLinearAnn OnRecField _ GhcPs = (EpToken "%1", TokDcolon)
+type instance XLinearAnn OnConField _ GhcPs = (EpToken "%1", TokDcolon)
type instance XLinearAnn _ _ GhcRn = NoExtField
type instance XLinearAnn _ _ GhcTc = NoExtField
type instance XExplicitMult OnArrow _ GhcPs = (EpToken "%", TokRarrow)
-type instance XExplicitMult OnRecField _ GhcPs = (EpToken "%", TokDcolon)
+type instance XExplicitMult OnConField _ GhcPs = (EpToken "%", TokDcolon)
type instance XExplicitMult _ _ GhcRn = NoExtField
type instance XExplicitMult _ _ GhcTc = NoExtField
type instance XXMultAnnOn _ _ (GhcPass _) = DataConCantHappen
-hsNoMultAnn :: NoAnn (XUnannotated on (LHsType GhcPs) GhcPs) => HsMultAnnOn on (LHsType GhcPs) GhcPs
-hsNoMultAnn = HsUnannotated HsUnannOne noAnn
+hsNoMultAnn :: NoAnn (XUnannotated on (LHsType GhcPs) GhcPs)
+ => HsMultAnnOn on (LHsType GhcPs) GhcPs
+hsNoMultAnn = HsUnannotated noAnn
isUnrestricted :: HsArrow GhcRn -> Bool
isUnrestricted (multAnnToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName
isUnrestricted _ = False
-multAnnToHsType :: HsMultAnnOn on (LHsType GhcRn) GhcRn -> LHsType GhcRn
+multAnnToHsType :: IsHsMultAnnOnWhat on => HsMultAnnOn on (LHsType GhcRn) GhcRn -> LHsType GhcRn
multAnnToHsType = expandHsMultAnnOn (HsTyVar noAnn NotPromoted)
-- | Convert an multiplicity annotation into its corresponding multiplicity.
-- In essence this erases the information of whether the programmer wrote an explicit
-- multiplicity or a shorthand.
-- In this polymorphic function, `t` can be `HsType` or `HsExpr`
-expandHsMultAnnOn :: (LocatedN Name -> t GhcRn) -> HsMultAnnOn on (LocatedA (t GhcRn)) GhcRn -> LocatedA (t GhcRn)
-expandHsMultAnnOn mk_var (HsUnannotated HsUnannOne _) = noLocA (mk_var (noLocA oneDataConName))
-expandHsMultAnnOn mk_var (HsUnannotated HsUnannMany _) = noLocA (mk_var (noLocA manyDataConName))
+expandHsMultAnnOn :: forall on t. IsHsMultAnnOnWhat on
+ => (LocatedN Name -> t GhcRn)
+ -> HsMultAnnOn on (LocatedA (t GhcRn)) GhcRn
+ -> LocatedA (t GhcRn)
+expandHsMultAnnOn mk_var (HsUnannotated _) = noLocA (mk_var (noLocA mult))
+ where
+ mult = case hsMultAnnOnWhat (Proxy :: Proxy on) of
+ OnArrow -> manyDataConName
+ OnConField -> oneDataConName
expandHsMultAnnOn mk_var (HsLinearAnn _) = noLocA (mk_var (noLocA oneDataConName))
expandHsMultAnnOn _mk_var (HsExplicitMult _ p) = p
@@ -574,7 +581,7 @@ instance
-- See #18846
pprHsArrow :: (Outputable mult, OutputableBndrId pass) => HsArrowOf mult (GhcPass pass) -> SDoc
-pprHsArrow (HsUnannotated _ _) = pprArrowWithMultiplicity visArgTypeLike (Left False)
+pprHsArrow (HsUnannotated _) = pprArrowWithMultiplicity visArgTypeLike (Left False)
pprHsArrow (HsLinearAnn _) = pprArrowWithMultiplicity visArgTypeLike (Left True)
pprHsArrow (HsExplicitMult _ p) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p))
@@ -591,7 +598,7 @@ instance OutputableBndrId p
ppr_mult :: HsMultAnnOn on (LHsType (GhcPass p)) (GhcPass p) -> SDoc -> SDoc
ppr_mult mult tyDoc = case mult of
- HsUnannotated _ _ -> dcolon <+> tyDoc
+ HsUnannotated _ -> dcolon <+> tyDoc
HsLinearAnn _ -> text "%1" <+> dcolon <+> tyDoc
HsExplicitMult _ p -> text "%" <> ppr p <+> dcolon <+> tyDoc
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -86,6 +86,7 @@ import GHC.Types.Name.Env
import GHC.TypeLits
import Data.Kind (Constraint)
+import Data.Proxy
import qualified GHC.LanguageExtensions as LangExt
@@ -2861,11 +2862,18 @@ 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 :: [HsConFieldSpec on GhcRn] -> MetaM ()
+verifyLinearFields :: forall on. IsHsMultAnnOnWhat on => [HsConFieldSpec on GhcRn] -> MetaM ()
verifyLinearFields ps = do
linear <- lift $ xoptM LangExt.LinearTypes
let allGood = all (hsMultIsLinear linear . cfs_multiplicity) ps
unless allGood $ notHandled ThNonLinearDataCon
+ where
+ hsMultIsLinear linearTypesEnabled (HsUnannotated _) =
+ case hsMultAnnOnWhat (Proxy :: Proxy on) of
+ OnArrow -> not linearTypesEnabled
+ OnConField -> True
+ hsMultIsLinear _ HsLinearAnn{} = True
+ hsMultIsLinear _ _ = False
-- Desugar the arguments in a data constructor declared with prefix syntax.
repPrefixConArgs :: [HsConFieldSpec OnArrow GhcRn]
@@ -2885,7 +2893,7 @@ repRecConArgs lips = do
where
rep_ip ip = mapM (rep_one_ip (cd_fld_spec ip)) (cd_fld_names ip)
- rep_one_ip :: HsConFieldSpec OnRecField GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
+ rep_one_ip :: HsConFieldSpec OnConField GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
rep_one_ip t n = do { MkC v <- lookupOcc (unLoc . foLabel $ unLoc n)
; MkC ty <- repConFieldSpec t
; rep2 varBangTypeName [v,ty] }
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1795,7 +1795,7 @@ instance ToHie (LocatedL [LocatedA (ConDeclField GhcRn)]) where
, toHie decls
]
-instance ToHie (HsConFieldSpec on GhcRn) where
+instance IsHsMultAnnOnWhat on => ToHie (HsConFieldSpec on GhcRn) where
toHie (CFS _ _ _ w t doc) = concatM
[ toHie (multAnnToHsType w)
, toHie t
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2601,7 +2601,7 @@ fielddecl :: { LConDeclField GhcPs }
(ConDeclField noExtField
(reverse (map (\ln@(L l n)
-> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1)))
- (mkConFieldSpec (HsUnannotated HsUnannOne (epUniTok $2)) $3)))}
+ (mkConFieldSpec (HsUnannotated (epUniTok $2)) $3)))}
| sig_vars PREFIX_PERCENT atype '::' ctype
{% amsA' (L (comb4 $1 $2 $3 $5)
(ConDeclField noExtField
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -3520,7 +3520,7 @@ 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 -> HsConFieldSpec OnRecField GhcPs
+mkMultField :: EpToken "%" -> LHsType GhcPs -> TokDcolon -> LHsType GhcPs -> HsConFieldSpec OnConField GhcPs
mkMultField pct (L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) col t
-- See #18888 for the use of (SourceText "1") above
= mkConFieldSpec (HsLinearAnn (pct1, col)) t
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -706,7 +706,7 @@ rnHsMultAnnOn env = rnHsMultAnnOnWith (rnLHsTyKi env)
rnHsMultAnnOnWith :: (LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars))
-> HsMultAnnOn on (LocatedA (mult GhcPs)) GhcPs
-> RnM (HsMultAnnOn on (LocatedA (mult GhcRn)) GhcRn, FreeVars)
-rnHsMultAnnOnWith _rn (HsUnannotated mult _) = pure (HsUnannotated mult noExtField, emptyFVs)
+rnHsMultAnnOnWith _rn (HsUnannotated _) = pure (HsUnannotated noExtField, emptyFVs)
rnHsMultAnnOnWith _rn (HsLinearAnn _) = pure (HsLinearAnn noExtField, emptyFVs)
rnHsMultAnnOnWith rn (HsExplicitMult _ p)
= (\(mult, fvs) -> (HsExplicitMult noExtField mult, fvs)) <$> rn p
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -1387,7 +1387,7 @@ rn_ty_pat ty@(XHsType{}) = do
liftRnFV $ rnHsType ctxt ty
rn_ty_pat_arrow :: HsArrow GhcPs -> TPRnM (HsArrow GhcRn)
-rn_ty_pat_arrow (HsUnannotated mult _) = pure (HsUnannotated mult noExtField)
+rn_ty_pat_arrow (HsUnannotated _) = pure (HsUnannotated noExtField)
rn_ty_pat_arrow (HsLinearAnn _) = pure (HsLinearAnn noExtField)
rn_ty_pat_arrow (HsExplicitMult _ p)
= rn_lty_pat p <&> (\mult -> HsExplicitMult noExtField mult)
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -991,7 +991,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 (HsUnannotated mult _) = pure (HsUnannotated mult noExtField)
+ go_arrow (HsUnannotated _) = pure (HsUnannotated noExtField)
go_arrow (HsLinearAnn{}) = pure (HsLinearAnn noExtField)
go_arrow (HsExplicitMult _ exp) = HsExplicitMult noExtField <$> go exp
go (L l (HsForAll _ tele expr)) =
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -947,7 +947,7 @@ concern things that the renamer can't handle.
-}
-tcMult :: HsMultAnnOn on (LHsType GhcRn) GhcRn -> TcM Mult
+tcMult :: IsHsMultAnnOnWhat on => HsMultAnnOn on (LHsType GhcRn) GhcRn -> TcM Mult
tcMult hc = tc_mult typeLevelMode hc
-- | Info about the context in which we're checking a type. Currently,
@@ -1364,7 +1364,7 @@ Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo
-}
------------------------------------------
-tc_mult :: TcTyMode -> HsMultAnnOn on (LHsType GhcRn) GhcRn -> TcM Mult
+tc_mult :: IsHsMultAnnOnWhat on => TcTyMode -> HsMultAnnOn on (LHsType GhcRn) GhcRn -> TcM Mult
tc_mult mode ty = tc_check_lhs_type mode (multAnnToHsType ty) multiplicityTy
------------------------------------------
tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> ExpKind
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -1806,7 +1806,8 @@ 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 :: ConArgKind -- Expected kind of the argument(s)
+kcConArgTys :: IsHsMultAnnOnWhat on
+ => ConArgKind -- Expected kind of the argument(s)
-> [HsConFieldSpec on GhcRn] -- User-written argument types
-> TcM ()
kcConArgTys exp_kind arg_tys
@@ -3988,7 +3989,8 @@ tcConGADTArgs exp_kind (PrefixConGADT _ btys)
tcConGADTArgs exp_kind (RecConGADT _ fields)
= tcRecConDeclFields exp_kind fields
-tcConArg :: ConArgKind -- expected kind for args; always OpenKind for datatypes,
+tcConArg :: IsHsMultAnnOnWhat on
+ => ConArgKind -- expected kind for args; always OpenKind for datatypes,
-- but might be an unlifted type with UnliftedNewtypes
-> HsConFieldSpec on GhcRn -> TcM (Scaled TcType, HsSrcBang)
tcConArg exp_kind (CFS (_, src) unp str w bty _)
@@ -4011,7 +4013,7 @@ tcRecConDeclFields exp_kind fields
exploded = concatMap explode combined
(_,btys) = unzip exploded
-tcDataConMult :: HsMultAnnOn on (LHsType GhcRn) GhcRn -> TcM Mult
+tcDataConMult :: IsHsMultAnnOnWhat on => HsMultAnnOn on (LHsType GhcRn) GhcRn -> TcM Mult
tcDataConMult arr@(HsUnrestrictedArrow _) = do
-- See Note [Function arrows in GADT constructors]
linearEnabled <- xoptM LangExt.LinearTypes
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -776,7 +776,8 @@ cvtSrcStrictness NoSourceStrictness = NoSrcStrict
cvtSrcStrictness SourceLazy = SrcLazy
cvtSrcStrictness SourceStrict = SrcStrict
-cvt_arg :: NoAnn (XUnannotated on (LHsType GhcPs) GhcPs) => (TH.Bang, TH.Type) -> CvtM (HsConFieldSpec on GhcPs)
+cvt_arg :: (NoAnn (XUnannotated on (LHsType GhcPs) GhcPs), IsHsMultAnnOnWhat on)
+ => (TH.Bang, TH.Type) -> CvtM (HsConFieldSpec on GhcPs)
cvt_arg (Bang su ss, ty)
= do { ty'' <- cvtType ty
; let ty' = parenthesizeHsType appPrec ty''
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -22,10 +22,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 (
- HsArrow, HsArrowOf, HsMultAnnOn(..), HsMultAnnOnWhat(..), HsUnannotatedMult(..),
+ HsArrow, HsArrowOf, HsMultAnnOn(..), HsMultAnnOnWhat(..), IsHsMultAnnOnWhat(..),
pattern HsUnrestrictedArrow,
XUnannotated, XLinearAnn, XExplicitMult, XXMultAnnOn,
- hsMultIsLinear,
HsType(..), LHsType, HsKind, LHsKind,
HsBndrVis(..), XBndrRequired, XBndrInvisible, XXBndrVis,
@@ -919,28 +918,35 @@ data HsTyLit pass
type HsArrow pass = HsArrowOf (LHsType pass) pass
type HsArrowOf = HsMultAnnOn OnArrow
--- HsMultAnnOn is used both to represent function arrows and multiplicity annotations
--- in the record declaration syntax. But the default multiplicity is different
--- between the two uses. In record syntax, the default is One, but on arrows, the
--- default is Many. `HsUnannotatedMult` is used to distinguish between the two uses.
-data HsUnannotatedMult = HsUnannOne | HsUnannMany
- deriving (Eq, Ord, Data)
-
pattern HsUnrestrictedArrow :: XUnannotated on mult pass -> HsMultAnnOn on mult pass
-pattern HsUnrestrictedArrow a = HsUnannotated HsUnannMany a
-
-data HsMultAnnOnWhat = OnArrow | OnRecField
+pattern HsUnrestrictedArrow a = HsUnannotated a
--- | Denotes the type of arrows in the surface language
+-- HsMultAnnOn is used both to represent function arrows and multiplicity annotations
+-- in the data declaration syntax. But the default multiplicity is different
+-- between the two uses. In constructors, the default is One, but on arrows, the
+-- default is Many. (But note that non-record GADT syntax follows the default of arrows.)
+-- `HsMultAnnOnWhat` is used to distinguish between the two uses.
+data HsMultAnnOnWhat = OnArrow | OnConField
+
+-- Get a value level representation of the `HsMultAnnOnWhat` kind.
+class IsHsMultAnnOnWhat (on :: HsMultAnnOnWhat) where
+ hsMultAnnOnWhat :: proxy on -> HsMultAnnOnWhat
+instance IsHsMultAnnOnWhat OnArrow where
+ hsMultAnnOnWhat _ = OnArrow
+instance IsHsMultAnnOnWhat OnConField where
+ hsMultAnnOnWhat _ = OnConField
+
+-- | Denotes multiplicity annotations in the surface language
data HsMultAnnOn (on :: HsMultAnnOnWhat) mult pass
- = HsUnannotated HsUnannotatedMult !(XUnannotated on mult pass)
- -- ^ a -> b or a → b
+ = HsUnannotated !(XUnannotated on mult pass)
+ -- ^ a -> b or a → b or { nm :: a }
| HsLinearAnn !(XLinearAnn on mult pass)
- -- ^ a %1 -> b or a %1 → b, or a ⊸ b
+ -- ^ a %1 -> b or a %1 → b, or a ⊸ b, or { nm %1 :: a }
| HsExplicitMult !(XExplicitMult on mult pass) !mult
- -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`!
+ -- ^ a %m -> b or a %m → b or { nm %m :: a }
+ -- (very much including `a %Many -> b`!
-- This is how the programmer wrote it). It is stored as an
-- `HsType` so as to preserve the syntax as written in the
-- program.
@@ -952,12 +958,6 @@ type family XLinearAnn (on :: HsMultAnnOnWhat) mult p
type family XExplicitMult (on :: HsMultAnnOnWhat) mult p
type family XXMultAnnOn (on :: HsMultAnnOnWhat) mult p
-hsMultIsLinear :: Bool -> HsMultAnnOn on mult pass -> Bool
-hsMultIsLinear _ (HsUnannotated HsUnannOne _) = True
-hsMultIsLinear linear (HsUnannotated HsUnannMany _) = not linear
-hsMultIsLinear _ HsLinearAnn{} = True
-hsMultIsLinear _ _ = False
-
{-
Note [Unit tuples]
~~~~~~~~~~~~~~~~~~
@@ -1061,7 +1061,7 @@ data ConDeclField pass
= ConDeclField { cd_fld_ext :: XConDeclField pass,
cd_fld_names :: [LFieldOcc pass],
-- ^ See Note [ConDeclField pass]
- cd_fld_spec :: HsConFieldSpec OnRecField pass }
+ cd_fld_spec :: HsConFieldSpec OnConField pass }
| XConDeclField !(XXConDeclField pass)
{- Note [ConDeclField pass]
=====================================
testsuite/tests/ghc-api/exactprint/Test20239.stderr
=====================================
@@ -257,7 +257,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { Test20239.hs:7:62-63 })
(NormalSyntax)))
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
=====================================
@@ -254,7 +254,6 @@
(NoSrcUnpack)
(NoSrcStrict)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { T17544_kw.hs:19:21-22 })
(NormalSyntax)))
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
=====================================
@@ -951,7 +951,6 @@
(NoSrcUnpack)
(NoSrcStrict)
(HsUnannotated
- (HsUnannOne)
(EpUniTok
(EpaSpan { T24221.hs:28:15-16 })
(NormalSyntax)))
@@ -1024,7 +1023,6 @@
(NoSrcUnpack)
(NoSrcStrict)
(HsUnannotated
- (HsUnannOne)
(EpUniTok
(EpaSpan { T24221.hs:29:15-16 })
(NormalSyntax)))
@@ -1184,7 +1182,6 @@
(NoSrcUnpack)
(NoSrcStrict)
(HsUnannotated
- (HsUnannOne)
(EpUniTok
(EpaSpan { T24221.hs:33:10-11 })
(NormalSyntax)))
@@ -1257,7 +1254,6 @@
(NoSrcUnpack)
(NoSrcStrict)
(HsUnannotated
- (HsUnannOne)
(EpUniTok
(EpaSpan { T24221.hs:34:10-11 })
(NormalSyntax)))
@@ -1429,7 +1425,6 @@
(NoSrcUnpack)
(NoSrcStrict)
(HsUnannotated
- (HsUnannOne)
(EpUniTok
(EpaSpan { T24221.hs:40:8-9 })
(NormalSyntax)))
@@ -1502,7 +1497,6 @@
(NoSrcUnpack)
(NoSrcStrict)
(HsUnannotated
- (HsUnannOne)
(EpUniTok
(EpaSpan { T24221.hs:42:8-9 })
(NormalSyntax)))
=====================================
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
=====================================
@@ -254,7 +254,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { DumpParsedAst.hs:9:20-21 })
(NormalSyntax)))
@@ -960,7 +959,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { DumpParsedAst.hs:17:14-15 })
(NormalSyntax)))
@@ -993,7 +991,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { DumpParsedAst.hs:17:29-30 })
(NormalSyntax)))
@@ -1020,7 +1017,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { DumpParsedAst.hs:17:20-21 })
(NormalSyntax)))
@@ -1407,7 +1403,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { DumpParsedAst.hs:18:33-34 })
(NormalSyntax)))
@@ -1540,7 +1535,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { DumpParsedAst.hs:21:22-23 })
(NormalSyntax)))
@@ -1573,7 +1567,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { DumpParsedAst.hs:21:27-28 })
(NormalSyntax)))
@@ -1699,7 +1692,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { DumpParsedAst.hs:22:30-31 })
(NormalSyntax)))
@@ -1772,7 +1764,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { DumpParsedAst.hs:22:54-55 })
(NormalSyntax)))
@@ -1799,7 +1790,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { DumpParsedAst.hs:22:45-46 })
(NormalSyntax)))
@@ -1908,7 +1898,6 @@
(NoSrcUnpack)
(NoSrcStrict)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { DumpParsedAst.hs:23:36-37 })
(NormalSyntax)))
@@ -1980,7 +1969,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { DumpParsedAst.hs:23:27-28 })
(NormalSyntax)))
=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -648,7 +648,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(NoExtField))
(L
(EpAnn
@@ -757,7 +756,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(NoExtField))
(L
(EpAnn
@@ -787,7 +785,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(NoExtField))
(L
(EpAnn
@@ -906,7 +903,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(NoExtField))
(L
(EpAnn
@@ -971,7 +967,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(NoExtField))
(L
(EpAnn
@@ -994,7 +989,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(NoExtField))
(L
(EpAnn
@@ -1093,7 +1087,6 @@
(NoSrcUnpack)
(NoSrcStrict)
(HsUnannotated
- (HsUnannMany)
(NoExtField))
(L
(EpAnn
@@ -1159,7 +1152,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(NoExtField))
(L
(EpAnn
@@ -1846,7 +1838,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(NoExtField))
(L
(EpAnn
@@ -1951,7 +1942,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(NoExtField))
(L
(EpAnn
@@ -1981,7 +1971,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(NoExtField))
(L
(EpAnn
@@ -2004,7 +1993,6 @@
(HsFunTy
(NoExtField)
(HsUnannotated
- (HsUnannMany)
(NoExtField))
(L
(EpAnn
=====================================
testsuite/tests/parser/should_compile/T14189.stderr
=====================================
@@ -207,7 +207,6 @@
(NoSrcUnpack)
(NoSrcStrict)
(HsUnannotated
- (HsUnannOne)
(NoExtField))
(L
(EpAnn
=====================================
testsuite/tests/printer/T18791.stderr
=====================================
@@ -128,7 +128,6 @@
(NoSrcUnpack)
(NoSrcStrict)
(HsUnannotated
- (HsUnannMany)
(EpUniTok
(EpaSpan { T18791.hs:5:14-15 })
(NormalSyntax)))
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -834,9 +834,9 @@ markEpUniToken (EpUniTok aa isUnicode) = do
-- ---------------------------------------------------------------------
markArrow :: (Monad m, Monoid w, ExactPrint a) => HsArrowOf a GhcPs -> EP w m (HsArrowOf a GhcPs)
-markArrow (HsUnannotated t arr) = do
+markArrow (HsUnannotated arr) = do
arr' <- markEpUniToken arr
- return (HsUnannotated t arr')
+ return (HsUnannotated arr')
markArrow (HsLinearAnn (EpPct1 pct1 arr)) = do
pct1' <- markEpToken pct1
arr' <- markEpUniToken arr
@@ -850,11 +850,11 @@ markArrow (HsExplicitMult (pct, arr) t) = do
arr' <- markEpUniToken arr
return (HsExplicitMult (pct', arr') t')
-markRecFieldMult :: (Monad m, Monoid w, ExactPrint a) => HsMultAnnOn OnRecField a GhcPs -> EP w m (HsMultAnnOn OnRecField a GhcPs)
-markRecFieldMult (HsUnannotated t col) = do
+markRecFieldMult :: (Monad m, Monoid w, ExactPrint a) => HsMultAnnOn OnConField a GhcPs -> EP w m (HsMultAnnOn OnConField a GhcPs)
+markRecFieldMult (HsUnannotated col) = do
traceM $ "markRecFieldMult:HsUnannotated"
col' <- markEpUniToken col
- return (HsUnannotated t col')
+ return (HsUnannotated col')
markRecFieldMult (HsLinearAnn (pct1, col)) = do
traceM $ "markRecFieldMult:HsLinearAnn"
pct1' <- markEpToken pct1
@@ -4449,7 +4449,7 @@ instance ExactPrint (HsConFieldSpec OnArrow GhcPs) where
arr' <- markArrow arr
return (CFS an' unp str arr' t' doc)
-instance ExactPrint (HsConFieldSpec OnRecField GhcPs) where
+instance ExactPrint (HsConFieldSpec OnConField GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
exact (CFS an unp str mult t doc) = do
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
=====================================
@@ -1049,7 +1049,7 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype) =
-- Where there is more than one name, they all have the same documentation
ppRecFieldMultAnn :: Bool -> HsConFieldSpec on DocNameI -> LaTeX -> LaTeX
ppRecFieldMultAnn unicode (CFS _ _ _ arr _ _) following = case arr of
- HsUnannotated _ _ -> following
+ HsUnannotated _ -> following
HsLinearAnn _ -> text "%1" <+> following
HsExplicitMult _ mult -> multAnnotation <> ppr_mono_lty mult unicode <+> following
@@ -1318,7 +1318,7 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u =
where
arr = case mult of
HsLinearAnn _ -> lollipop u
- HsUnannotated _ _ -> arrow u
+ HsUnannotated _ -> arrow u
HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u
ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
ppr_mono_ty (HsTyVar _ IsPromoted (L _ name)) _ = char '\'' <> ppDocName name
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
=====================================
@@ -1557,7 +1557,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype) =
-- Where there is more than one name, they all have the same documentation
ppRecFieldMultAnn :: Unicode -> Qualification -> HsConFieldSpec on DocNameI -> Html -> Html
ppRecFieldMultAnn unicode qual (CFS _ _ _ arr _ _) following = case arr of
- HsUnannotated _ _ -> following
+ HsUnannotated _ -> following
HsLinearAnn _ -> toHtml "%1" <+> following
HsExplicitMult _ mult -> multAnnotation <> ppr_mono_lty mult unicode qual HideEmptyContexts <+> following
@@ -1821,7 +1821,7 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =
where
arr = case mult of
HsLinearAnn _ -> lollipop u
- HsUnannotated _ _ -> arrow u
+ HsUnannotated _ -> 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
=====================================
@@ -990,9 +990,9 @@ synifyMult vs t = case t of
ManyTy -> HsUnrestrictedArrow noExtField
ty -> HsExplicitMult noExtField (synifyType WithinType vs ty)
-synifyMultRec :: [TyVar] -> Mult -> HsMultAnnOn OnRecField (LHsType GhcRn) GhcRn
+synifyMultRec :: [TyVar] -> Mult -> HsMultAnnOn OnConField (LHsType GhcRn) GhcRn
synifyMultRec vs t = case t of
- OneTy -> HsUnannotated HsUnannOne noExtField
+ OneTy -> HsUnannotated noExtField
ty -> HsExplicitMult noExtField (synifyType WithinType vs ty)
synifyPatSynType :: PatSyn -> LHsType GhcRn
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -341,7 +341,7 @@ renameMaybeInjectivityAnn
renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameMultAnnOn :: HsMultAnnOn on (LHsType GhcRn) GhcRn -> RnM (HsMultAnnOn on (LHsType DocNameI) DocNameI)
-renameMultAnnOn (HsUnannotated mult _) = return (HsUnannotated mult noExtField)
+renameMultAnnOn (HsUnannotated _) = return (HsUnannotated noExtField)
renameMultAnnOn (HsLinearAnn _) = return (HsLinearAnn noExtField)
renameMultAnnOn (HsExplicitMult _ p) = HsExplicitMult noExtField <$> renameLType p
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1a49aa49ca942643866890c20f074fd1b3e4a1a4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1a49aa49ca942643866890c20f074fd1b3e4a1a4
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/20250123/f9c9e4f6/attachment-0001.html>
More information about the ghc-commits
mailing list