summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRichard Eisenberg <eir@cis.upenn.edu>2016-02-04 10:42:56 -0500
committerRichard Eisenberg <eir@cis.upenn.edu>2016-02-24 13:31:30 -0500
commitd8c64e86361f6766ebe26a262bb229fb8301a42a (patch)
tree94d68ebcb1cc6e9eabff08d3cd1d7e61dd99c01e
parentce36115b369510c51f402073174d82d0d1244589 (diff)
downloadhaskell-wip/runtime-rep.tar.gz
Address #11471 by putting RuntimeRep in kinds.wip/runtime-rep
See Note [TYPE] in TysPrim. There are still some outstanding pieces in #11471 though, so this doesn't actually nail the bug. This commit also contains a few performance improvements: * Short-cut equality checking of nullary type syns * Compare types before kinds in eqType * INLINE coreViewOneStarKind * Store tycon binders separately from kinds. This resulted in a ~10% performance improvement in compiling the Cabal package. No change in functionality other than performance. (This affects the interface file format, though.) This commit updates the haddock submodule.
-rw-r--r--compiler/basicTypes/DataCon.hs22
-rw-r--r--compiler/basicTypes/MkId.hs29
-rw-r--r--compiler/basicTypes/PatSyn.hs4
-rw-r--r--compiler/coreSyn/CoreLint.hs4
-rw-r--r--compiler/coreSyn/CorePrep.hs2
-rw-r--r--compiler/coreSyn/MkCore.hs20
-rw-r--r--compiler/deSugar/DsBinds.hs2
-rw-r--r--compiler/deSugar/DsForeign.hs8
-rw-r--r--compiler/deSugar/DsUtils.hs4
-rw-r--r--compiler/ghci/RtClosureInspect.hs4
-rw-r--r--compiler/iface/BinIface.hs2
-rw-r--r--compiler/iface/BuildTyCl.hs9
-rw-r--r--compiler/iface/IfaceEnv.hs2
-rw-r--r--compiler/iface/IfaceSyn.hs148
-rw-r--r--compiler/iface/IfaceType.hs119
-rw-r--r--compiler/iface/MkIface.hs35
-rw-r--r--compiler/iface/TcIface.hs96
-rw-r--r--compiler/prelude/PrelNames.hs38
-rw-r--r--compiler/prelude/PrimOp.hs2
-rw-r--r--compiler/prelude/TysPrim.hs192
-rw-r--r--compiler/prelude/TysWiredIn.hs267
-rw-r--r--compiler/prelude/TysWiredIn.hs-boot22
-rw-r--r--compiler/typecheck/Inst.hs127
-rw-r--r--compiler/typecheck/TcBinds.hs2
-rw-r--r--compiler/typecheck/TcCanonical.hs4
-rw-r--r--compiler/typecheck/TcDeriv.hs2
-rw-r--r--compiler/typecheck/TcErrors.hs26
-rw-r--r--compiler/typecheck/TcExpr.hs12
-rw-r--r--compiler/typecheck/TcHsSyn.hs26
-rw-r--r--compiler/typecheck/TcHsType.hs325
-rw-r--r--compiler/typecheck/TcInstDcls.hs7
-rw-r--r--compiler/typecheck/TcInteract.hs2
-rw-r--r--compiler/typecheck/TcMType.hs34
-rw-r--r--compiler/typecheck/TcPat.hs4
-rw-r--r--compiler/typecheck/TcPatSyn.hs18
-rw-r--r--compiler/typecheck/TcRnDriver.hs2
-rw-r--r--compiler/typecheck/TcSMonad.hs6
-rw-r--r--compiler/typecheck/TcSimplify.hs22
-rw-r--r--compiler/typecheck/TcSplice.hs36
-rw-r--r--compiler/typecheck/TcTyClsDecls.hs196
-rw-r--r--compiler/typecheck/TcType.hs12
-rw-r--r--compiler/typecheck/TcTypeNats.hs12
-rw-r--r--compiler/typecheck/TcUnify.hs19
-rw-r--r--compiler/typecheck/TcValidity.hs4
-rw-r--r--compiler/types/Kind.hs30
-rw-r--r--compiler/types/TyCoRep.hs92
-rw-r--r--compiler/types/TyCoRep.hs-boot2
-rw-r--r--compiler/types/TyCon.hs302
-rw-r--r--compiler/types/Type.hs133
-rw-r--r--compiler/utils/Util.hs16
-rw-r--r--compiler/vectorise/Vectorise/Exp.hs2
-rw-r--r--compiler/vectorise/Vectorise/Generic/PData.hs3
-rw-r--r--compiler/vectorise/Vectorise/Type/Env.hs2
-rw-r--r--compiler/vectorise/Vectorise/Type/TyConDecl.hs5
-rw-r--r--libraries/base/Data/Data.hs2
-rw-r--r--libraries/base/Data/Typeable/Internal.hs28
-rw-r--r--libraries/base/GHC/Err.hs8
-rwxr-xr-xlibraries/base/GHC/Exts.hs4
-rw-r--r--libraries/base/tests/T11334.hs4
-rw-r--r--libraries/ghc-prim/GHC/Types.hs73
-rw-r--r--testsuite/tests/dependent/should_compile/T11405.hs2
-rw-r--r--testsuite/tests/dependent/should_fail/BadTelescope4.stderr6
-rw-r--r--testsuite/tests/dependent/should_fail/TypeSkolEscape.hs2
-rw-r--r--testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr10
-rw-r--r--testsuite/tests/ghci/scripts/T4175.stdout10
-rw-r--r--testsuite/tests/ghci/scripts/T7627.stdout8
-rw-r--r--testsuite/tests/ghci/scripts/T7939.stdout19
-rw-r--r--testsuite/tests/ghci/scripts/T8535.stdout2
-rw-r--r--testsuite/tests/ghci/scripts/T9181.stdout18
-rw-r--r--testsuite/tests/ghci/scripts/ghci020.stdout2
-rw-r--r--testsuite/tests/ghci/should_run/T10145.stdout2
-rw-r--r--testsuite/tests/indexed-types/should_compile/T3017.stderr4
-rw-r--r--testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr45
-rw-r--r--testsuite/tests/indexed-types/should_fail/Overlap4.stderr9
-rw-r--r--testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr3
-rw-r--r--testsuite/tests/indexed-types/should_fail/TyFamArity1.stderr8
-rw-r--r--testsuite/tests/indexed-types/should_fail/TyFamArity2.stderr13
-rw-r--r--testsuite/tests/indexed-types/should_run/T11465a.hs2
-rw-r--r--testsuite/tests/partial-sigs/should_compile/ADT.stderr1
-rw-r--r--testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr1
-rw-r--r--testsuite/tests/partial-sigs/should_compile/Meltdown.stderr3
-rw-r--r--testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr1
-rw-r--r--testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr3
-rw-r--r--testsuite/tests/partial-sigs/should_compile/SkipMany.stderr1
-rw-r--r--testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr3
-rw-r--r--testsuite/tests/perf/compiler/all.T3
-rw-r--r--testsuite/tests/polykinds/T11399.stderr4
-rw-r--r--testsuite/tests/polykinds/T7328.stderr2
-rw-r--r--testsuite/tests/polykinds/TidyClassKinds.stderr2
-rw-r--r--testsuite/tests/roles/should_compile/Roles1.stderr7
-rw-r--r--testsuite/tests/roles/should_compile/Roles2.stderr2
-rw-r--r--testsuite/tests/roles/should_compile/Roles3.stderr6
-rw-r--r--testsuite/tests/roles/should_compile/T8958.stderr1
-rw-r--r--testsuite/tests/simplCore/should_compile/T9400.stderr2
-rw-r--r--testsuite/tests/simplCore/should_compile/spec-inline.stderr2
-rw-r--r--testsuite/tests/th/TH_Roles2.stderr5
-rw-r--r--testsuite/tests/typecheck/should_compile/tc231.stderr2
-rw-r--r--testsuite/tests/typecheck/should_run/KindInvariant.stderr3
-rw-r--r--testsuite/tests/typecheck/should_run/TypeOf.hs4
-rw-r--r--testsuite/tests/typecheck/should_run/TypeOf.stdout4
-rw-r--r--utils/genprimopcode/Main.hs114
m---------utils/haddock0
102 files changed, 1755 insertions, 1221 deletions
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs
index 8552205483..57a9857cd4 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/basicTypes/DataCon.hs
@@ -720,6 +720,7 @@ mkDataCon :: Name
-> ThetaType -- ^ Theta-type occuring before the arguments proper
-> [Type] -- ^ Original argument types
-> Type -- ^ Original result type
+ -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo'
-> TyCon -- ^ Representation type constructor
-> ThetaType -- ^ The "stupid theta", context of the data
-- declaration e.g. @data Eq a => T a ...@
@@ -733,7 +734,7 @@ mkDataCon name declared_infix prom_info
fields
univ_tvs ex_tvs
eq_spec theta
- orig_arg_tys orig_res_ty rep_tycon
+ orig_arg_tys orig_res_ty rep_info rep_tycon
stupid_theta work_id rep
-- Warning: mkDataCon is not a good place to check invariants.
-- If the programmer writes the wrong result type in the decl, thus:
@@ -774,8 +775,15 @@ mkDataCon name declared_infix prom_info
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
- promoted -- See Note [Promoted data constructors] in TyCon
- = mkPromotedDataCon con name prom_info (dataConUserType con) roles
+ -- See Note [Promoted data constructors] in TyCon
+ prom_binders = map (mkNamedBinder Specified)
+ ((univ_tvs `minusList` map eqSpecTyVar eq_spec) ++
+ ex_tvs) ++
+ map mkAnonBinder theta ++
+ map mkAnonBinder orig_arg_tys
+ prom_res_kind = orig_res_ty
+ promoted
+ = mkPromotedDataCon con name prom_info prom_binders prom_res_kind roles rep_info
roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
map (const Representational) orig_arg_tys
@@ -1106,9 +1114,7 @@ isVanillaDataCon dc = dcVanilla dc
-- | Should this DataCon be allowed in a type even without -XDataKinds?
-- Currently, only Lifted & Unlifted
specialPromotedDc :: DataCon -> Bool
-specialPromotedDc dc
- = dc `hasKey` liftedDataConKey ||
- dc `hasKey` unliftedDataConKey
+specialPromotedDc = isKindTyCon . dataConTyCon
-- | Was this datacon promotable before GHC 8.0? That is, is it promotable
-- without -XTypeInType
@@ -1228,7 +1234,7 @@ buildAlgTyCon :: Name
buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
is_rec gadt_syn parent
- = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
+ = mkAlgTyCon tc_name binders liftedTypeKind ktvs roles cType stupid_theta
rhs parent is_rec gadt_syn
where
- kind = mkPiTypesPreferFunTy ktvs liftedTypeKind
+ binders = mkTyBindersPreferAnon ktvs liftedTypeKind
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index a64e922e21..8ee5013a96 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -1062,11 +1062,11 @@ dollarId = pcMiscPrelId dollarName ty
(noCafIdInfo `setUnfoldingInfo` unf)
where
fun_ty = mkFunTy alphaTy openBetaTy
- ty = mkSpecForAllTys [levity2TyVar, alphaTyVar, openBetaTyVar] $
+ ty = mkSpecForAllTys [runtimeRep2TyVar, alphaTyVar, openBetaTyVar] $
mkFunTy fun_ty fun_ty
unf = mkInlineUnfolding (Just 2) rhs
[f,x] = mkTemplateLocals [fun_ty, alphaTy]
- rhs = mkLams [levity2TyVar, alphaTyVar, openBetaTyVar, f, x] $
+ rhs = mkLams [runtimeRep2TyVar, alphaTyVar, openBetaTyVar, f, x] $
App (Var f) (Var x)
------------------------------------------------
@@ -1083,7 +1083,9 @@ proxyHashId
t = mkTyVarTy tv
------------------------------------------------
--- unsafeCoerce# :: forall a b. a -> b
+-- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
+-- (a :: TYPE r1) (b :: TYPE r2).
+-- a -> b
unsafeCoerceId :: Id
unsafeCoerceId
= pcMiscPrelId unsafeCoerceName ty info
@@ -1091,14 +1093,13 @@ unsafeCoerceId
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
- ty = mkSpecForAllTys [ levity1TyVar, levity2TyVar
- , openAlphaTyVar, openBetaTyVar ]
- (mkFunTy openAlphaTy openBetaTy)
+ tvs = [ runtimeRep1TyVar, runtimeRep2TyVar
+ , openAlphaTyVar, openBetaTyVar ]
+
+ ty = mkSpecForAllTys tvs $ mkFunTy openAlphaTy openBetaTy
[x] = mkTemplateLocals [openAlphaTy]
- rhs = mkLams [ levity1TyVar, levity2TyVar
- , openAlphaTyVar, openBetaTyVar
- , x] $
+ rhs = mkLams (tvs ++ [x]) $
Cast (Var x) (mkUnsafeCo Representational openAlphaTy openBetaTy)
------------------------------------------------
@@ -1166,13 +1167,13 @@ oneShotId = pcMiscPrelId oneShotName ty info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
- ty = mkSpecForAllTys [ levity1TyVar, levity2TyVar
+ ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar
, openAlphaTyVar, openBetaTyVar ]
(mkFunTy fun_ty fun_ty)
- fun_ty = mkFunTy alphaTy betaTy
+ fun_ty = mkFunTy openAlphaTy openBetaTy
[body, x] = mkTemplateLocals [fun_ty, openAlphaTy]
x' = setOneShotLambda x
- rhs = mkLams [ levity1TyVar, levity2TyVar
+ rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar
, openAlphaTyVar, openBetaTyVar
, body, x'] $
Var body `App` Var x
@@ -1196,7 +1197,7 @@ runRWId = pcMiscPrelId runRWName ty info
arg_ty = stateRW `mkFunTy` ret_ty
-- (State# RealWorld -> (# State# RealWorld, o #))
-- -> (# State# RealWorld, o #)
- ty = mkSpecForAllTys [levity1TyVar, openAlphaTyVar] $
+ ty = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] $
arg_ty `mkFunTy` ret_ty
--------------------------------------------------------------------------------
@@ -1375,7 +1376,7 @@ no further floating will occur. This allows us to safely inline things like
While the definition of @GHC.Magic.runRW#@, we override its type in @MkId@
to be open-kinded,
- runRW# :: forall (lev :: Levity). (o :: TYPE lev)
+ runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)
=> (State# RealWorld -> (# State# RealWorld, o #))
-> (# State# RealWorld, o #)
diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs
index 65826583dd..cef94767a9 100644
--- a/compiler/basicTypes/PatSyn.hs
+++ b/compiler/basicTypes/PatSyn.hs
@@ -79,7 +79,7 @@ data PatSyn
-- Matcher function.
-- If Bool is True then prov_theta and arg_tys are empty
-- and type is
- -- forall (v :: Levity) (r :: TYPE v) univ_tvs.
+ -- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs.
-- req_theta
-- => res_ty
-- -> (forall ex_tvs. Void# -> r)
@@ -87,7 +87,7 @@ data PatSyn
-- -> r
--
-- Otherwise type is
- -- forall (v :: Levity) (r :: TYPE v) univ_tvs.
+ -- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs.
-- req_theta
-- => res_ty
-- -> (forall ex_tvs. prov_theta => arg_tys -> r)
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 6dbcbe4ce9..f9cb4be3b3 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -988,8 +988,8 @@ lintAndScopeId id linterF
(text "Non-local Id binder" <+> ppr id)
-- See Note [Checking for global Ids]
; (ty, k) <- lintInTy (idType id)
- ; lintL (not (isLevityPolymorphic k))
- (text "Levity polymorphic binder:" <+>
+ ; lintL (not (isRuntimeRepPolymorphic k))
+ (text "RuntimeRep-polymorphic binder:" <+>
(ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k)))
; let id' = setIdType id ty
; addInScopeVar id' $ (linterF id') }
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 4708df3f48..3f9f4c8470 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -512,7 +512,7 @@ cpeRhsE env (Var f `App` _{-type-} `App` arg)
| f `hasKey` lazyIdKey -- Replace (lazy a) by a
= cpeRhsE env arg -- See Note [lazyId magic] in MkId
-cpeRhsE env (Var f `App` _levity `App` _type `App` arg)
+cpeRhsE env (Var f `App` _runtimeRep `App` _type `App` arg)
-- See Note [runRW magic] in MkId
| f `hasKey` runRWKey -- Replace (runRW# f) by (f realWorld#),
= case arg of -- beta reducing if possible
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index 94a264c120..0eccccc2e4 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -322,13 +322,13 @@ mkCoreTup cs = mkCoreConApps (tupleDataCon Boxed (length cs))
-- | Build a small unboxed tuple holding the specified expressions,
-- with the given types. The types must be the types of the expressions.
--- Do not include the levity specifiers; this function calculates them
+-- Do not include the RuntimeRep specifiers; this function calculates them
-- for you.
mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup tys exps
= ASSERT( tys `equalLength` exps)
mkCoreConApps (tupleDataCon Unboxed (length tys))
- (map (Type . getLevity "mkCoreUbxTup") tys ++ map Type tys ++ exps)
+ (map (Type . getRuntimeRep "mkCoreUbxTup") tys ++ map Type tys ++ exps)
-- | Make a core tuple of the given boxity
mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
@@ -588,7 +588,8 @@ mkRuntimeErrorApp
-> CoreExpr
mkRuntimeErrorApp err_id res_ty err_msg
- = mkApps (Var err_id) [Type (getLevity "mkRuntimeErrorApp" res_ty), Type res_ty, err_string]
+ = mkApps (Var err_id) [ Type (getRuntimeRep "mkRuntimeErrorApp" res_ty)
+ , Type res_ty, err_string ]
where
err_string = Lit (mkMachString err_msg)
@@ -672,21 +673,18 @@ mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy
runtimeErrorTy :: Type
-- The runtime error Ids take a UTF8-encoded string as argument
-runtimeErrorTy = mkSpecSigmaTy [levity1TyVar, openAlphaTyVar] []
+runtimeErrorTy = mkSpecSigmaTy [runtimeRep1TyVar, openAlphaTyVar] []
(mkFunTy addrPrimTy openAlphaTy)
{-
Note [Error and friends have an "open-tyvar" forall]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'error' and 'undefined' have types
- error :: forall (v :: Levity) (a :: TYPE v). String -> a
- undefined :: forall (v :: Levity) (a :: TYPE v). a
-Notice the levity polymophism. This ensures that
-"error" can be instantiated at
- * unboxed as well as boxed types
- * polymorphic types
+ error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a
+ undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a
+Notice the runtime-representation polymophism. This ensures that
+"error" can be instantiated at unboxed as well as boxed types.
This is OK because it never returns, so the return type is irrelevant.
-See Note [Sort-polymorphic tyvars accept foralls] in TcMType.
************************************************************************
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 4f05d07942..420090db36 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -1067,7 +1067,7 @@ dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg
dsEvDelayedError :: Type -> FastString -> CoreExpr
dsEvDelayedError ty msg
- = Var errorId `mkTyApps` [getLevity "dsEvTerm" ty, ty] `mkApps` [litMsg]
+ = Var errorId `mkTyApps` [getRuntimeRep "dsEvTerm" ty, ty] `mkApps` [litMsg]
where
errorId = tYPE_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs
index a87526ff6c..26c84c764d 100644
--- a/compiler/deSugar/DsForeign.hs
+++ b/compiler/deSugar/DsForeign.hs
@@ -198,7 +198,10 @@ dsFCall fn_id co fcall mDeclHeader = do
ty = pFst $ coercionKind co
(all_bndrs, io_res_ty) = tcSplitPiTys ty
(named_bndrs, arg_tys) = partitionBindersIntoBinders all_bndrs
- tvs = map (binderVar "dsFCall") named_bndrs
+ tvs = ASSERT( fst (span isNamedBinder all_bndrs)
+ `equalLength` named_bndrs )
+ -- ensure that the named binders all come first
+ map (binderVar "dsFCall") named_bndrs
-- Must use tcSplit* functions because we want to
-- see that (IO t) in the corner
@@ -302,6 +305,7 @@ dsPrimCall fn_id co fcall = do
-- Must use tcSplit* functions because we want to
-- see that (IO t) in the corner
+ MASSERT( fst (span isNamedBinder bndrs) `equalLength` tvs )
args <- newSysLocalsDs arg_tys
ccall_uniq <- newUnique
@@ -412,6 +416,8 @@ dsFExportDynamic :: Id
-> CCallConv
-> DsM ([Binding], SDoc, SDoc)
dsFExportDynamic id co0 cconv = do
+ MASSERT( fst (span isNamedBinder bndrs) `equalLength` tvs )
+ -- make sure that the named binders all come first
fe_id <- newSysLocalDs ty
mod <- getModule
dflags <- getDynFlags
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index 0ddfb97529..ece50d877a 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -343,7 +343,7 @@ sort_alts = sortWith (dataConTag . alt_pat)
mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
mkPatSynCase var ty alt fail = do
matcher <- dsLExpr $ mkLHsWrap wrapper $
- nlHsTyApp matcher [getLevity "mkPatSynCase" ty, ty]
+ nlHsTyApp matcher [getRuntimeRep "mkPatSynCase" ty, ty]
let MatchResult _ mkCont = match_result
cont <- mkCoreLams bndrs <$> mkCont fail
return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
@@ -469,7 +469,7 @@ mkErrorAppDs err_id ty msg = do
full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
core_msg = Lit (mkMachString full_msg)
-- mkMachString returns a result of type String#
- return (mkApps (Var err_id) [Type (getLevity "mkErrorAppDs" ty), Type ty, core_msg])
+ return (mkApps (Var err_id) [Type (getRuntimeRep "mkErrorAppDs" ty), Type ty, core_msg])
{-
'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 1832ea4819..a76a298172 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -800,8 +800,8 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos)
go ptr_i ws (ty:tys)
| Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
, isUnboxedTupleTyCon tc
- -- See Note [Unboxed tuple levity vars] in TyCon
- = do (ptr_i, ws, terms0) <- go ptr_i ws (dropLevityArgs elem_tys)
+ -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+ = do (ptr_i, ws, terms0) <- go ptr_i ws (dropRuntimeRepArgs elem_tys)
(ptr_i, ws, terms1) <- go ptr_i ws tys
return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
| otherwise
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index c0926fc22e..a7246afc03 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -344,7 +344,7 @@ putTupleName_ bh tc tup_sort thing_tag
(sort_tag, arity) = case tup_sort of
BoxedTuple -> (0, fromIntegral (tyConArity tc))
UnboxedTuple -> (1, fromIntegral (tyConArity tc `div` 2))
- -- See Note [Unboxed tuple levity vars] in TyCon
+ -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
ConstraintTuple -> pprPanic "putTupleName:ConstraintTuple" (ppr tc)
-- See Note [Symbol table representation of names]
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 0022e29f11..87b5f36b7e 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -138,7 +138,7 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
data_con = mkDataCon src_name declared_infix prom_info
src_bangs field_lbls
univ_tvs ex_tvs eq_spec ctxt
- arg_tys res_ty rep_tycon
+ arg_tys res_ty NoRRI rep_tycon
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
@@ -215,7 +215,7 @@ type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> [TyVar] -> [Role] -> ThetaType
- -> Kind
+ -> [TyBinder]
-> [FunDep TyVar] -- Functional dependencies
-> [ClassATItem] -- Associated types
-> [TcMethInfo] -- Method info
@@ -223,7 +223,8 @@ buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> RecFlag -- Info for type constructor
-> TcRnIf m n Class
-buildClass tycon_name tvs roles sc_theta kind fds at_items sig_stuff mindef tc_isrec
+buildClass tycon_name tvs roles sc_theta binders
+ fds at_items sig_stuff mindef tc_isrec
= fixM $ \ rec_clas -> -- Only name generation inside loop
do { traceIf (text "buildClass")
@@ -286,7 +287,7 @@ buildClass tycon_name tvs roles sc_theta kind fds at_items sig_stuff mindef tc_i
, tup_sort = ConstraintTuple })
else return (mkDataTyConRhs [dict_con])
- ; let { tycon = mkClassTyCon tycon_name kind tvs roles
+ ; let { tycon = mkClassTyCon tycon_name binders tvs roles
rhs rec_clas tc_isrec tc_rep_name
-- A class can be recursive, and in the case of newtypes
-- this matters. For example
diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs
index 43094f94aa..20b497bee3 100644
--- a/compiler/iface/IfaceEnv.hs
+++ b/compiler/iface/IfaceEnv.hs
@@ -49,7 +49,7 @@ import Data.List ( partition )
Note [The Name Cache]
~~~~~~~~~~~~~~~~~~~~~
-The Name Cache makes sure that, during any invovcation of GHC, each
+The Name Cache makes sure that, during any invocation of GHC, each
External Name "M.x" has one, and only one globally-agreed Unique.
* The first time we come across M.x we make up a Unique and record that
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 7b6b34c728..91132851a8 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -95,9 +95,9 @@ data IfaceDecl
ifIdInfo :: IfaceIdInfo }
| IfaceData { ifName :: IfaceTopBndr, -- Type constructor
- ifKind :: IfaceType, -- Kind of type constructor
+ ifBinders :: [IfaceTyConBinder],
+ ifResKind :: IfaceType, -- Result kind of type constructor
ifCType :: Maybe CType, -- C type for CAPI FFI
- ifTyVars :: [IfaceTvBndr], -- Type variables
ifRoles :: [Role], -- Roles
ifCtxt :: IfaceContext, -- The "stupid theta"
ifCons :: IfaceConDecls, -- Includes new/data/data family info
@@ -109,25 +109,24 @@ data IfaceDecl
}
| IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor
- ifTyVars :: [IfaceTvBndr], -- Type variables
ifRoles :: [Role], -- Roles
- ifSynKind :: IfaceKind, -- Kind of the *tycon*
+ ifBinders :: [IfaceTyConBinder],
+ ifResKind :: IfaceKind, -- Kind of the *result*
ifSynRhs :: IfaceType }
| IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor
- ifTyVars :: [IfaceTvBndr], -- Type variables
ifResVar :: Maybe IfLclName, -- Result variable name, used
-- only for pretty-printing
-- with --show-iface
- ifFamKind :: IfaceKind, -- Kind of the *tycon*
+ ifBinders :: [IfaceTyConBinder],
+ ifResKind :: IfaceKind, -- Kind of the *tycon*
ifFamFlav :: IfaceFamTyConFlav,
ifFamInj :: Injectivity } -- injectivity information
| IfaceClass { ifCtxt :: IfaceContext, -- Superclasses
ifName :: IfaceTopBndr, -- Name of the class TyCon
- ifTyVars :: [IfaceTvBndr], -- Type variables
ifRoles :: [Role], -- Roles
- ifKind :: IfaceType, -- Kind of TyCon
+ ifBinders :: [IfaceTyConBinder],
ifFDs :: [FunDep FastString], -- Functional dependencies
ifATs :: [IfaceAT], -- Associated type families
ifSigs :: [IfaceClassOp], -- Method signatures
@@ -619,11 +618,11 @@ pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
-- See Note [Pretty-printing TyThings] in PprTyThing
pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
- ifCtxt = context, ifTyVars = tc_tyvars,
+ ifCtxt = context,
ifRoles = roles, ifCons = condecls,
ifParent = parent, ifRec = isrec,
ifGadtSyntax = gadt,
- ifKind = kind })
+ ifBinders = binders })
| gadt_style = vcat [ pp_roles
, pp_nd <+> pp_lhs <+> pp_where
@@ -641,14 +640,14 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
pp_cons = ppr_trim (map show_con cons) :: [SDoc]
pp_lhs = case parent of
- IfNoParent -> pprIfaceDeclHead context ss tycon kind tc_tyvars
+ IfNoParent -> pprIfaceDeclHead context ss tycon binders Nothing
_ -> text "instance" <+> pprIfaceTyConParent parent
pp_roles
| is_data_instance = empty
| otherwise = pprRoles (== Representational)
(pprPrefixIfDeclBndr ss tycon)
- tc_bndrs roles
+ binders roles
-- Don't display roles for data family instances (yet)
-- See discussion on Trac #8672.
@@ -658,50 +657,29 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc)
show_con dc
- | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls dc
+ | ok_con dc = Just $ pprIfaceConDecl ss gadt_style fls tycon binders parent dc
| otherwise = Nothing
fls = ifaceConDeclFields condecls
- mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
- -- See Note [Result type of a data family GADT]
- mk_user_con_res_ty eq_spec
- | IfDataInstance _ tc tys <- parent
- = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys)))
- | otherwise
- = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst))
- where
- gadt_subst = mkFsEnv eq_spec
- done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv)
- con_univ_tvs = filterOut done_univ_tv tc_tyvars
-
- ppr_tc_app gadt_subst dflags
- = pprPrefixIfDeclBndr ss tycon
- <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv)
- | (tv,_kind)
- <- suppressIfaceInvisibles dflags tc_bndrs tc_tyvars ]
- (tc_bndrs, _, _) = splitIfaceSigmaTy kind
-
pp_nd = case condecls of
IfAbstractTyCon d -> text "abstract" <> ppShowIface ss (parens (ppr d))
IfDataTyCon{} -> text "data"
IfNewTyCon{} -> text "newtype"
- pp_extra = vcat [pprCType ctype, pprRec isrec, text "Kind:" <+> ppr kind]
+ pp_extra = vcat [pprCType ctype, pprRec isrec]
pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
, ifCtxt = context, ifName = clas
- , ifTyVars = tyvars, ifRoles = roles
+ , ifRoles = roles
, ifFDs = fds, ifMinDef = minDef
- , ifKind = kind })
- = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) bndrs roles
- , text "class" <+> pprIfaceDeclHead context ss clas kind tyvars
+ , ifBinders = binders })
+ = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) binders roles
+ , text "class" <+> pprIfaceDeclHead context ss clas binders Nothing
<+> pprFundeps fds <+> pp_where
, nest 2 (vcat [ vcat asocs, vcat dsigs, pprec
, ppShowAllSubs ss (pprMinDef minDef)])]
where
- (bndrs, _, _) = splitIfaceSigmaTy kind
-
pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where")
asocs = ppr_trim $ map maybeShowAssoc ats
@@ -726,26 +704,27 @@ pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
text "#-}"
pprIfaceDecl ss (IfaceSynonym { ifName = tc
- , ifTyVars = tv
+ , ifBinders = binders
, ifSynRhs = mono_ty
- , ifSynKind = kind})
- = hang (text "type" <+> pprIfaceDeclHead [] ss tc kind tv <+> equals)
- 2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau])
+ , ifResKind = res_kind})
+ = hang (text "type" <+> pprIfaceDeclHead [] ss tc binders Nothing <+> equals)
+ 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau
+ , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ])
where
(tvs, theta, tau) = splitIfaceSigmaTy mono_ty
-pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
- , ifFamFlav = rhs, ifFamKind = kind
+pprIfaceDecl ss (IfaceFamily { ifName = tycon
+ , ifFamFlav = rhs, ifBinders = binders
+ , ifResKind = res_kind
, ifResVar = res_var, ifFamInj = inj })
| IfaceDataFamilyTyCon <- rhs
- = text "data family" <+> pprIfaceDeclHead [] ss tycon kind tyvars
+ = text "data family" <+> pprIfaceDeclHead [] ss tycon binders Nothing
| otherwise
- = hang (text "type family" <+> pprIfaceDeclHead [] ss tycon kind tyvars)
+ = hang (text "type family" <+> pprIfaceDeclHead [] ss tycon binders (Just res_kind))
2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))
$$
- nest 2 ( vcat [ text "Kind:" <+> ppr kind
- , ppShowRhs ss (pp_branches rhs) ] )
+ nest 2 (ppShowRhs ss (pp_branches rhs))
where
pp_inj Nothing _ = empty
pp_inj (Just res) inj
@@ -753,9 +732,9 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
, pp_inj_cond res injectivity]
| otherwise = hsep [ equals, ppr res ]
- pp_inj_cond res inj = case filterByList inj tyvars of
+ pp_inj_cond res inj = case filterByList inj binders of
[] -> empty
- tvs -> hsep [vbar, ppr res, text "->", interppSP (map fst tvs)]
+ tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)]
pp_rhs IfaceDataFamilyTyCon
= ppShowIface ss (text "data")
@@ -808,7 +787,7 @@ pprCType (Just cType) = text "C type:" <+> ppr cType
-- if, for each role, suppress_if role is True, then suppress the role
-- output
-pprRoles :: (Role -> Bool) -> SDoc -> [IfaceForAllBndr]
+pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder]
-> [Role] -> SDoc
pprRoles suppress_if tyCon bndrs roles
= sdocWithDynFlags $ \dflags ->
@@ -862,15 +841,15 @@ pprIfaceTyConParent (IfDataInstance _ tc tys)
in pprIfaceTypeApp tc ftys
pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName
- -> IfaceType -- of the tycon, for invisible-suppression
- -> [IfaceTvBndr] -> SDoc
-pprIfaceDeclHead context ss tc_occ kind tyvars
+ -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression
+ -> Maybe IfaceKind
+ -> SDoc
+pprIfaceDeclHead context ss tc_occ bndrs m_res_kind
= sdocWithDynFlags $ \ dflags ->
sep [ pprIfaceContextArr context
, pprPrefixIfDeclBndr ss tc_occ
- <+> pprIfaceTvBndrs (suppressIfaceInvisibles dflags bndrs tyvars) ]
- where
- (bndrs, _, _) = splitIfaceSigmaTy kind
+ <+> pprIfaceTyConBinders (suppressIfaceInvisibles dflags bndrs bndrs)
+ , maybe empty (\res_kind -> dcolon <+> pprIfaceType res_kind) m_res_kind ]
isVanillaIfaceConDecl :: IfaceConDecl -> Bool
isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs
@@ -879,10 +858,12 @@ isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs
= (null ex_tvs) && (null eq_spec) && (null ctxt)
pprIfaceConDecl :: ShowSub -> Bool
- -> (IfaceEqSpec -> ([IfaceTvBndr], SDoc))
-> [FieldLbl OccName]
+ -> IfaceTopBndr
+ -> [IfaceTyConBinder]
+ -> IfaceTyConParent
-> IfaceConDecl -> SDoc
-pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls
+pprIfaceConDecl ss gadt_style fls tycon tc_binders parent
(IfCon { ifConOcc = name, ifConInfix = is_infix,
ifConExTvs = ex_tvs,
ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
@@ -935,6 +916,25 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls
-- DuplicateRecordFields was used for the definition)
lbl = maybe sel (mkVarOccFS . flLabel) $ find (\ fl -> flSelector fl == sel) fls
+ mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
+ -- See Note [Result type of a data family GADT]
+ mk_user_con_res_ty eq_spec
+ | IfDataInstance _ tc tys <- parent
+ = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys)))
+ | otherwise
+ = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst))
+ where
+ gadt_subst = mkFsEnv eq_spec
+ done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv)
+ con_univ_tvs = filterOut done_univ_tv (map ifTyConBinderTyVar tc_binders)
+
+ ppr_tc_app gadt_subst dflags
+ = pprPrefixIfDeclBndr ss tycon
+ <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv)
+ | (tv,_kind)
+ <- map ifTyConBinderTyVar $
+ suppressIfaceInvisibles dflags tc_binders tc_binders ]
+
instance Outputable IfaceRule where
ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
@@ -1149,23 +1149,22 @@ freeNamesIfDecl (IfaceId _s t d i) =
freeNamesIfIdInfo i &&&
freeNamesIfIdDetails d
freeNamesIfDecl d@IfaceData{} =
- freeNamesIfType (ifKind d) &&&
- freeNamesIfTvBndrs (ifTyVars d) &&&
+ freeNamesIfTyBinders (ifBinders d) &&&
+ freeNamesIfType (ifResKind d) &&&
freeNamesIfaceTyConParent (ifParent d) &&&
freeNamesIfContext (ifCtxt d) &&&
freeNamesIfConDecls (ifCons d)
freeNamesIfDecl d@IfaceSynonym{} =
- freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfType (ifSynRhs d) &&&
- freeNamesIfKind (ifSynKind d)
+ freeNamesIfTyBinders (ifBinders d) &&&
+ freeNamesIfKind (ifResKind d)
freeNamesIfDecl d@IfaceFamily{} =
- freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfFamFlav (ifFamFlav d) &&&
- freeNamesIfKind (ifFamKind d)
+ freeNamesIfTyBinders (ifBinders d) &&&
+ freeNamesIfKind (ifResKind d)
freeNamesIfDecl d@IfaceClass{} =
- freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfContext (ifCtxt d) &&&
- freeNamesIfType (ifKind d) &&&
+ freeNamesIfTyBinders (ifBinders d) &&&
fnList freeNamesIfAT (ifATs d) &&&
fnList freeNamesIfClsSig (ifSigs d)
freeNamesIfDecl d@IfaceAxiom{} =
@@ -1305,6 +1304,13 @@ freeNamesIfTvBndrs = fnList freeNamesIfTvBndr
freeNamesIfForAllBndr :: IfaceForAllBndr -> NameSet
freeNamesIfForAllBndr (IfaceTv tv _) = freeNamesIfTvBndr tv
+freeNamesIfTyBinder :: IfaceTyConBinder -> NameSet
+freeNamesIfTyBinder (IfaceAnon _ ty) = freeNamesIfType ty
+freeNamesIfTyBinder (IfaceNamed b) = freeNamesIfForAllBndr b
+
+freeNamesIfTyBinders :: [IfaceTyConBinder] -> NameSet
+freeNamesIfTyBinders = fnList freeNamesIfTyBinder
+
freeNamesIfBndr :: IfaceBndr -> NameSet
freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b
freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b
@@ -1475,7 +1481,7 @@ instance Binary IfaceDecl where
put_ bh a5
put_ bh a6
- put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
+ put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
putByte bh 5
put_ bh a1
put_ bh (occNameFS a2)
@@ -1486,7 +1492,6 @@ instance Binary IfaceDecl where
put_ bh a7
put_ bh a8
put_ bh a9
- put_ bh a10
put_ bh (IfaceAxiom a1 a2 a3 a4) = do
putByte bh 6
@@ -1555,9 +1560,8 @@ instance Binary IfaceDecl where
a7 <- get bh
a8 <- get bh
a9 <- get bh
- a10 <- get bh
occ <- return $! mkClsOccFS a2
- return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9 a10)
+ return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9)
6 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index ee7e4308d8..52454ffb5e 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -17,18 +17,21 @@ module IfaceType (
IfaceTyCon(..), IfaceTyConInfo(..),
IfaceTyLit(..), IfaceTcArgs(..),
IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
- IfaceTvBndr, IfaceIdBndr,
+ IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder(..),
IfaceForAllBndr(..), VisibilityFlag(..),
+ ifConstraintKind, ifTyConBinderTyVar, ifTyConBinderName,
+
-- Equality testing
IfRnEnv2, emptyIfRnEnv2, eqIfaceType, eqIfaceTypes,
- eqIfaceTcArgs, eqIfaceTvBndrs,
+ eqIfaceTcArgs, eqIfaceTvBndrs, isIfaceLiftedTypeKind,
-- Conversion from Type -> IfaceType
toIfaceType, toIfaceTypes, toIfaceKind, toIfaceTyVar,
toIfaceContext, toIfaceBndr, toIfaceIdBndr,
toIfaceTyCon, toIfaceTyCon_name,
toIfaceTcArgs, toIfaceTvBndrs,
+ zipIfaceBinders, toDegenerateBinders,
-- Conversion from IfaceTcArgs -> IfaceType
tcArgsIfaceTypes,
@@ -39,7 +42,7 @@ module IfaceType (
-- Printing
pprIfaceType, pprParendIfaceType,
pprIfaceContext, pprIfaceContextArr, pprIfaceContextMaybe,
- pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTvBndrs,
+ pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,
pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType,
pprIfaceCoercion, pprParendIfaceCoercion,
@@ -59,7 +62,6 @@ import DataCon ( isTupleDataCon )
import TcType
import DynFlags
import TyCoRep -- needs to convert core types to iface types
-import Unique( hasKey )
import TyCon hiding ( pprPromotionQuote )
import CoAxiom
import Id
@@ -67,7 +69,7 @@ import Var
-- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv )
import TysWiredIn
import TysPrim
-import PrelNames( funTyConKey, ipClassKey )
+import PrelNames
import Name
import BasicTypes
import Binary
@@ -145,6 +147,11 @@ data IfaceTyLit
data IfaceForAllBndr
= IfaceTv IfaceTvBndr VisibilityFlag
+data IfaceTyConBinder
+ = IfaceAnon IfLclName IfaceType -- like Anon, but it includes a name from
+ -- which to produce a tyConTyVar
+ | IfaceNamed IfaceForAllBndr
+
-- See Note [Suppressing invisible arguments]
-- We use a new list type (rather than [(IfaceType,Bool)], because
-- it'll be more compact and faster to parse in interface
@@ -194,6 +201,12 @@ data IfaceUnivCoProv
| IfaceProofIrrelProv IfaceCoercion
| IfacePluginProv String
+-- this constant is needed for dealing with pretty-printing classes
+ifConstraintKind :: IfaceKind
+ifConstraintKind = IfaceTyConApp (IfaceTyCon { ifaceTyConName = getName constraintKindTyCon
+ , ifaceTyConInfo = NoIfaceTyConInfo })
+ ITC_Nil
+
{-
%************************************************************************
%* *
@@ -205,6 +218,15 @@ data IfaceUnivCoProv
eqIfaceTvBndr :: IfaceTvBndr -> IfaceTvBndr -> Bool
eqIfaceTvBndr (occ1, _) (occ2, _) = occ1 == occ2
+isIfaceLiftedTypeKind :: IfaceKind -> Bool
+isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil)
+ = isLiftedTypeKindTyConName (ifaceTyConName tc)
+isIfaceLiftedTypeKind (IfaceTyConApp tc
+ (ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil))
+ = ifaceTyConName tc == tYPETyConName
+ && ifaceTyConName ptr_rep_lifted `hasKey` ptrRepLiftedDataConKey
+isIfaceLiftedTypeKind _ = False
+
splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType)
-- Mainly for printing purposes
splitIfaceSigmaTy ty
@@ -221,7 +243,7 @@ splitIfaceSigmaTy ty
= case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
split_rho tau = ([], tau)
-suppressIfaceInvisibles :: DynFlags -> [IfaceForAllBndr] -> [a] -> [a]
+suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a]
suppressIfaceInvisibles dflags tys xs
| gopt Opt_PrintExplicitKinds dflags = xs
| otherwise = suppress tys xs
@@ -232,14 +254,25 @@ suppressIfaceInvisibles dflags tys xs
| isIfaceInvisBndr k = suppress ks xs
| otherwise = a
-stripIfaceInvisVars :: DynFlags -> [IfaceForAllBndr] -> [IfaceForAllBndr]
+stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder]
stripIfaceInvisVars dflags tyvars
| gopt Opt_PrintExplicitKinds dflags = tyvars
| otherwise = filterOut isIfaceInvisBndr tyvars
-isIfaceInvisBndr :: IfaceForAllBndr -> Bool
-isIfaceInvisBndr (IfaceTv _ Visible) = False
-isIfaceInvisBndr _ = True
+isIfaceInvisBndr :: IfaceTyConBinder -> Bool
+isIfaceInvisBndr (IfaceNamed (IfaceTv _ Invisible)) = True
+isIfaceInvisBndr (IfaceNamed (IfaceTv _ Specified)) = True
+isIfaceInvisBndr _ = False
+
+-- | Extract a IfaceTvBndr from a IfaceTyConBinder
+ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr
+ifTyConBinderTyVar (IfaceAnon name ki) = (name, ki)
+ifTyConBinderTyVar (IfaceNamed (IfaceTv tv _)) = tv
+
+-- | Extract the variable name from a IfaceTyConBinder
+ifTyConBinderName :: IfaceTyConBinder -> IfLclName
+ifTyConBinderName (IfaceAnon name _) = name
+ifTyConBinderName (IfaceNamed (IfaceTv (name, _) _)) = name
ifTyVarsOfType :: IfaceType -> UniqSet IfLclName
ifTyVarsOfType ty
@@ -568,16 +601,15 @@ pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc
pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty)
pprIfaceTvBndr :: IfaceTvBndr -> SDoc
-pprIfaceTvBndr (tv, IfaceTyConApp tc ITC_Nil)
- | isLiftedTypeKindTyConName (ifaceTyConName tc) = ppr tv
-pprIfaceTvBndr (tv, IfaceTyConApp tc (ITC_Vis (IfaceTyConApp lifted ITC_Nil) ITC_Nil))
- | ifaceTyConName tc == tYPETyConName
- , ifaceTyConName lifted == liftedDataConName
- = ppr tv
-pprIfaceTvBndr (tv, kind) = parens (ppr tv <+> dcolon <+> ppr kind)
+pprIfaceTvBndr (tv, ki)
+ | isIfaceLiftedTypeKind ki = ppr tv
+ | otherwise = parens (ppr tv <+> dcolon <+> ppr ki)
-pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
-pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars)
+pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc
+pprIfaceTyConBinders = sep . map go
+ where
+ go (IfaceAnon name ki) = pprIfaceTvBndr (name, ki)
+ go (IfaceNamed (IfaceTv tv _)) = pprIfaceTvBndr tv
instance Binary IfaceBndr where
put_ bh (IfaceIdBndr aa) = do
@@ -786,11 +818,14 @@ pprTyTcApp ctxt_prec tc tys dflags
= pprIfaceTyList ctxt_prec ty1 ty2
| ifaceTyConName tc == tYPETyConName
- , ITC_Vis (IfaceTyConApp lev_tc ITC_Nil) ITC_Nil <- tys
- = let n = ifaceTyConName lev_tc in
- if n == liftedDataConName then char '*'
- else if n == unliftedDataConName then char '#'
- else pprPanic "IfaceType.pprTyTcApp" (ppr lev_tc)
+ , ITC_Vis (IfaceTyConApp ptr_rep ITC_Nil) ITC_Nil <- tys
+ , ifaceTyConName ptr_rep `hasKey` ptrRepLiftedDataConKey
+ = char '*'
+
+ | ifaceTyConName tc == tYPETyConName
+ , ITC_Vis (IfaceTyConApp ptr_rep ITC_Nil) ITC_Nil <- tys
+ , ifaceTyConName ptr_rep `hasKey` ptrRepUnliftedDataConKey
+ = char '#'
| otherwise
= ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
@@ -826,8 +861,8 @@ ppr_iface_tc_app pp ctxt_prec tc tys
pprTuple :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> SDoc
pprTuple sort info args
- = -- drop the levity vars.
- -- See Note [Unboxed tuple levity vars] in TyCon
+ = -- drop the RuntimeRep vars.
+ -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
let tys = tcArgsIfaceTypes args
args' = case sort of
UnboxedTuple -> drop (length tys `div` 2) tys
@@ -968,6 +1003,21 @@ instance Binary IfaceForAllBndr where
vis <- get bh
return (IfaceTv tv vis)
+instance Binary IfaceTyConBinder where
+ put_ bh (IfaceAnon n ty) = putByte bh 0 >> put_ bh n >> put_ bh ty
+ put_ bh (IfaceNamed b) = putByte bh 1 >> put_ bh b
+
+ get bh =
+ do c <- getByte bh
+ case c of
+ 0 -> do
+ n <- get bh
+ ty <- get bh
+ return $! IfaceAnon n ty
+ _ -> do
+ b <- get bh
+ return $! IfaceNamed b
+
instance Binary IfaceTcArgs where
put_ bh tk =
case tk of
@@ -1360,3 +1410,20 @@ toIfaceUnivCoProv (PhantomProv co) = IfacePhantomProv (toIfaceCoercion co)
toIfaceUnivCoProv (ProofIrrelProv co) = IfaceProofIrrelProv (toIfaceCoercion co)
toIfaceUnivCoProv (PluginProv str) = IfacePluginProv str
toIfaceUnivCoProv (HoleProv h) = pprPanic "toIfaceUnivCoProv hit a hole" (ppr h)
+
+----------------------
+-- | Zip together tidied tyConTyVars with tyConBinders to make IfaceTyConBinders
+zipIfaceBinders :: [TyVar] -> [TyBinder] -> [IfaceTyConBinder]
+zipIfaceBinders = zipWith go
+ where
+ go tv (Anon _) = let (name, ki) = toIfaceTvBndr tv in
+ IfaceAnon name ki
+ go tv (Named _ vis) = IfaceNamed (IfaceTv (toIfaceTvBndr tv) vis)
+
+-- | Make IfaceTyConBinders without tyConTyVars. Used for pretty-printing only
+toDegenerateBinders :: [TyBinder] -> [IfaceTyConBinder]
+toDegenerateBinders = zipWith go [1..]
+ where
+ go :: Int -> TyBinder -> IfaceTyConBinder
+ go n (Anon ty) = IfaceAnon (mkFastString ("t" ++ show n)) (toIfaceType ty)
+ go _ (Named tv vis) = IfaceNamed (IfaceTv (toIfaceTvBndr tv) vis)
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 8548eb3031..4bd5c3611f 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -76,7 +76,6 @@ import DataCon
import PatSyn
import Type
import TcType
-import TysPrim ( alphaTyVars )
import InstEnv
import FamInstEnv
import TcRnMonad
@@ -1377,28 +1376,28 @@ tyConToIfaceDecl env tycon
| Just syn_rhs <- synTyConRhs_maybe tycon
= ( tc_env1
, IfaceSynonym { ifName = getOccName tycon,
- ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifSynRhs = if_syn_type syn_rhs,
- ifSynKind = if_kind
+ ifBinders = if_binders,
+ ifResKind = if_res_kind
})
| Just fam_flav <- famTyConFlav_maybe tycon
= ( tc_env1
, IfaceFamily { ifName = getOccName tycon,
- ifTyVars = if_tc_tyvars,
ifResVar = if_res_var,
ifFamFlav = to_if_fam_flav fam_flav,
- ifFamKind = if_kind,
+ ifBinders = if_binders,
+ ifResKind = if_res_kind,
ifFamInj = familyTyConInjectivityInfo tycon
})
| isAlgTyCon tycon
= ( tc_env1
, IfaceData { ifName = getOccName tycon,
- ifKind = if_kind,
+ ifBinders = if_binders,
+ ifResKind = if_res_kind,
ifCType = tyConCType tycon,
- ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
ifCons = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon),
@@ -1410,12 +1409,10 @@ tyConToIfaceDecl env tycon
-- For pretty printing purposes only.
= ( env
, IfaceData { ifName = getOccName tycon,
- ifKind =
- -- These don't have `tyConTyVars`, so we use an empty
- -- environment here, instead of `tc_env1` defined below.
- tidyToIfaceType emptyTidyEnv (tyConKind tycon),
+ ifBinders = if_degenerate_binders,
+ ifResKind = if_degenerate_res_kind,
+ -- These don't have `tyConTyVars`, hence "degenerate"
ifCType = Nothing,
- ifTyVars = funAndPrimTyVars,
ifRoles = tyConRoles tycon,
ifCtxt = [],
ifCons = IfDataTyCon [] False [],
@@ -1427,12 +1424,16 @@ tyConToIfaceDecl env tycon
-- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause
-- an error.
(tc_env1, tc_tyvars) = tidyTyClTyCoVarBndrs env (tyConTyVars tycon)
- if_tc_tyvars = toIfaceTvBndrs tc_tyvars
- if_kind = tidyToIfaceType tc_env1 (tyConKind tycon)
+ if_binders = zipIfaceBinders tc_tyvars (tyConBinders tycon)
+ if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon)
if_syn_type ty = tidyToIfaceType tc_env1 ty
if_res_var = getFS `fmap` tyConFamilyResVar_maybe tycon
- funAndPrimTyVars = toIfaceTvBndrs $ take (tyConArity tycon) alphaTyVars
+ -- use these when you don't have tyConTyVars
+ (degenerate_binders, degenerate_res_kind)
+ = splitPiTys (tidyType env (tyConKind tycon))
+ if_degenerate_binders = toDegenerateBinders degenerate_binders
+ if_degenerate_res_kind = toIfaceType degenerate_res_kind
parent = case tyConFamInstSig_maybe tycon of
Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
@@ -1522,9 +1523,8 @@ classToIfaceDecl env clas
= ( env1
, IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta,
ifName = getOccName tycon,
- ifTyVars = toIfaceTvBndrs clas_tyvars',
ifRoles = tyConRoles (classTyCon clas),
- ifKind = tidyToIfaceType env1 (tyConKind tycon),
+ ifBinders = binders,
ifFDs = map toIfaceFD clas_fds,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
@@ -1536,6 +1536,7 @@ classToIfaceDecl env clas
tycon = classTyCon clas
(env1, clas_tyvars') = tidyTyCoVarBndrs env clas_tyvars
+ binders = zipIfaceBinders clas_tyvars' (tyConBinders tycon)
toIfaceAT :: ClassATItem -> IfaceAT
toIfaceAT (ATI tc def)
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 2e8a6ed796..8599afabec 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -312,20 +312,21 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
tc_iface_decl _ _ (IfaceData {ifName = occ_name,
ifCType = cType,
- ifKind = kind,
- ifTyVars = tv_bndrs,
+ ifBinders = binders,
+ ifResKind = res_kind,
ifRoles = roles,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec, ifParent = mb_parent })
- = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
+ = bindIfaceTyConBinders_AT binders $ \ tyvars binders' -> do
{ tc_name <- lookupIfaceTop occ_name
- ; kind' <- tcIfaceType kind
+ ; res_kind' <- tcIfaceType res_kind
+
; tycon <- fixM $ \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
; parent' <- tc_parent tc_name mb_parent
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
- ; return (mkAlgTyCon tc_name kind' tyvars roles cType stupid_theta
+ ; return (mkAlgTyCon tc_name binders' res_kind' tyvars roles cType stupid_theta
cons parent' is_rec gadt_syn) }
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
@@ -341,31 +342,33 @@ tc_iface_decl _ _ (IfaceData {ifName = occ_name,
; lhs_tys <- tcIfaceTcArgs arg_tys
; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
-tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs,
+tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name,
ifRoles = roles,
ifSynRhs = rhs_ty,
- ifSynKind = kind })
- = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
+ ifBinders = binders,
+ ifResKind = res_kind })
+ = bindIfaceTyConBinders_AT binders $ \ tyvars binders' -> do
{ tc_name <- lookupIfaceTop occ_name
- ; kind <- tcIfaceType kind -- Note [Synonym kind loop]
+ ; res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop]
; rhs <- forkM (mk_doc tc_name) $
tcIfaceType rhs_ty
- ; let tycon = mkSynonymTyCon tc_name kind tyvars roles rhs
+ ; let tycon = mkSynonymTyCon tc_name binders' res_kind' tyvars roles rhs
; return (ATyCon tycon) }
where
mk_doc n = text "Type synonym" <+> ppr n
-tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs,
+tc_iface_decl parent _ (IfaceFamily {ifName = occ_name,
ifFamFlav = fam_flav,
- ifFamKind = kind,
+ ifBinders = binders,
+ ifResKind = res_kind,
ifResVar = res, ifFamInj = inj })
- = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
- { tc_name <- lookupIfaceTop occ_name
- ; kind <- tcIfaceType kind -- Note [Synonym kind loop]
+ = bindIfaceTyConBinders_AT binders $ \ tyvars binders' -> do
+ { tc_name <- lookupIfaceTop occ_name
+ ; res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop]
; rhs <- forkM (mk_doc tc_name) $
tc_fam_flav tc_name fam_flav
; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
- ; let tycon = mkFamilyTyCon tc_name kind tyvars res_name rhs parent inj
+ ; let tycon = mkFamilyTyCon tc_name binders' res_kind' tyvars res_name rhs parent inj
; return (ATyCon tycon) }
where
mk_doc n = text "Type synonym" <+> ppr n
@@ -386,15 +389,15 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs,
tc_iface_decl _parent ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
- ifTyVars = tv_bndrs, ifRoles = roles, ifKind = kind,
+ ifRoles = roles,
+ ifBinders = binders,
ifFDs = rdr_fds,
ifATs = rdr_ats, ifSigs = rdr_sigs,
ifMinDef = mindef_occ, ifRec = tc_isrec })
-- ToDo: in hs-boot files we should really treat abstract classes specially,
-- as we do abstract tycons
- = bindIfaceTvBndrs tv_bndrs $ \ tyvars -> do
+ = bindIfaceTyConBinders binders $ \ tyvars binders' -> do
{ tc_name <- lookupIfaceTop tc_occ
- ; kind' <- tcIfaceType kind
; traceIf (text "tc-iface-class1" <+> ppr tc_occ)
; ctxt <- mapM tc_sc rdr_ctxt
; traceIf (text "tc-iface-class2" <+> ppr tc_occ)
@@ -405,7 +408,7 @@ tc_iface_decl _parent ignore_prags
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
- ; buildClass tc_name tyvars roles ctxt kind' fds ats sigs mindef tc_isrec }
+ ; buildClass tc_name tyvars roles ctxt binders' fds ats sigs mindef tc_isrec }
; return (ATyCon (classTyCon cls)) }
where
tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
@@ -509,7 +512,8 @@ tc_ax_branch prev_branches
(IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs
, ifaxbLHS = lhs, ifaxbRHS = rhs
, ifaxbRoles = roles, ifaxbIncomps = incomps })
- = bindIfaceTyVars_AT tv_bndrs $ \ tvs ->
+ = bindIfaceTyConBinders_AT
+ (map (\b -> IfaceNamed (IfaceTv b Invisible)) tv_bndrs) $ \ tvs _ ->
-- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
bindIfaceIds cv_bndrs $ \ cvs -> do
{ tc_lhs <- tcIfaceTcArgs lhs
@@ -905,7 +909,7 @@ tcIfaceTupleTy sort info args
kind_args = map typeKind args'
; return (mkTyConApp tc (kind_args ++ args')) } }
--- See Note [Unboxed tuple levity vars] in TyCon
+-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr)
-> TupleSort
-> Arity -- the number of args. *not* the tuple arity.
@@ -1024,7 +1028,7 @@ tcIfaceExpr (IfaceTuple sort args)
; let con_tys = map exprType args'
some_con_args = map Type con_tys ++ args'
con_args = case sort of
- UnboxedTuple -> map (Type . getLevity "tcIfaceExpr") con_tys ++ some_con_args
+ UnboxedTuple -> map (Type . getRuntimeRep "tcIfaceExpr") con_tys ++ some_con_args
_ -> some_con_args
-- Put the missing type arguments back in
con_id = dataConWorkId (tyConSingleDataCon tc)
@@ -1426,21 +1430,39 @@ mk_iface_tyvar name ifKind
= do { kind <- tcIfaceType ifKind
; return (Var.mkTyVar name kind) }
-bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
+bindIfaceTyConBinders :: [IfaceTyConBinder]
+ -> ([TyVar] -> [TyBinder] -> IfL a) -> IfL a
+bindIfaceTyConBinders [] thing_inside = thing_inside [] []
+bindIfaceTyConBinders (b:bs) thing_inside
+ = bindIfaceTyConBinderX bindIfaceTyVar b $ \ tv' b' ->
+ bindIfaceTyConBinders bs $ \ tvs' bs' ->
+ thing_inside (tv':tvs') (b':bs')
+
+bindIfaceTyConBinders_AT :: [IfaceTyConBinder]
+ -> ([TyVar] -> [TyBinder] -> IfL a) -> IfL a
-- Used for type variable in nested associated data/type declarations
-- where some of the type variables are already in scope
-- class C a where { data T a b }
-- Here 'a' is in scope when we look at the 'data T'
-bindIfaceTyVars_AT [] thing_inside
- = thing_inside []
-bindIfaceTyVars_AT (b : bs) thing_inside
- = do { bindIfaceTyVar_AT b $ \b' ->
- bindIfaceTyVars_AT bs $ \bs' ->
- thing_inside (b':bs') }
-
-bindIfaceTyVar_AT :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
-bindIfaceTyVar_AT tv thing
- = do { mb_tv <- lookupIfaceTyVar tv
- ; case mb_tv of
- Just b' -> thing b'
- Nothing -> bindIfaceTyVar tv thing }
+bindIfaceTyConBinders_AT [] thing_inside
+ = thing_inside [] []
+bindIfaceTyConBinders_AT (b : bs) thing_inside
+ = bindIfaceTyConBinderX bind_tv b $ \tv' b' ->
+ bindIfaceTyConBinders_AT bs $ \tvs' bs' ->
+ thing_inside (tv':tvs') (b':bs')
+ where
+ bind_tv tv thing
+ = do { mb_tv <- lookupIfaceTyVar tv
+ ; case mb_tv of
+ Just b' -> thing b'
+ Nothing -> bindIfaceTyVar tv thing }
+
+bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a)
+ -> IfaceTyConBinder
+ -> (TyVar -> TyBinder -> IfL a) -> IfL a
+bindIfaceTyConBinderX bind_tv (IfaceAnon name ki) thing_inside
+ = bind_tv (name, ki) $ \ tv' ->
+ thing_inside tv' (Anon (tyVarKind tv'))
+bindIfaceTyConBinderX bind_tv (IfaceNamed (IfaceTv tv vis)) thing_inside
+ = bind_tv tv $ \tv' ->
+ thing_inside tv' (Named tv' vis)
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 5c2984be2a..068f276d05 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -1617,15 +1617,18 @@ eitherTyConKey = mkPreludeTyConUnique 84
-- Kind constructors
liftedTypeKindTyConKey, tYPETyConKey,
- unliftedTypeKindTyConKey, constraintKindTyConKey, levityTyConKey,
- starKindTyConKey, unicodeStarKindTyConKey :: Unique
+ unliftedTypeKindTyConKey, constraintKindTyConKey,
+ starKindTyConKey, unicodeStarKindTyConKey, runtimeRepTyConKey,
+ vecCountTyConKey, vecElemTyConKey :: Unique
liftedTypeKindTyConKey = mkPreludeTyConUnique 87
tYPETyConKey = mkPreludeTyConUnique 88
unliftedTypeKindTyConKey = mkPreludeTyConUnique 89
-levityTyConKey = mkPreludeTyConUnique 90
constraintKindTyConKey = mkPreludeTyConUnique 92
starKindTyConKey = mkPreludeTyConUnique 93
unicodeStarKindTyConKey = mkPreludeTyConUnique 94
+runtimeRepTyConKey = mkPreludeTyConUnique 95
+vecCountTyConKey = mkPreludeTyConUnique 96
+vecElemTyConKey = mkPreludeTyConUnique 97
pluginTyConKey, frontendPluginTyConKey :: Unique
pluginTyConKey = mkPreludeTyConUnique 102
@@ -1808,11 +1811,6 @@ fingerprintDataConKey = mkPreludeDataConUnique 35
srcLocDataConKey :: Unique
srcLocDataConKey = mkPreludeDataConUnique 37
--- Levity
-liftedDataConKey, unliftedDataConKey :: Unique
-liftedDataConKey = mkPreludeDataConUnique 39
-unliftedDataConKey = mkPreludeDataConUnique 40
-
trTyConTyConKey, trTyConDataConKey,
trModuleTyConKey, trModuleDataConKey,
trNameTyConKey, trNameSDataConKey, trNameDDataConKey,
@@ -1861,6 +1859,26 @@ metaDataDataConKey = mkPreludeDataConUnique 68
metaConsDataConKey = mkPreludeDataConUnique 69
metaSelDataConKey = mkPreludeDataConUnique 70
+vecRepDataConKey :: Unique
+vecRepDataConKey = mkPreludeDataConUnique 71
+
+-- See Note [Wiring in RuntimeRep] in TysWiredIn
+runtimeRepSimpleDataConKeys :: [Unique]
+ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey :: Unique
+runtimeRepSimpleDataConKeys@(
+ ptrRepLiftedDataConKey : ptrRepUnliftedDataConKey : _)
+ = map mkPreludeDataConUnique [72..82]
+
+-- See Note [Wiring in RuntimeRep] in TysWiredIn
+-- VecCount
+vecCountDataConKeys :: [Unique]
+vecCountDataConKeys = map mkPreludeDataConUnique [83..88]
+
+-- See Note [Wiring in RuntimeRep] in TysWiredIn
+-- VecElem
+vecElemDataConKeys :: [Unique]
+vecElemDataConKeys = map mkPreludeDataConUnique [89..98]
+
---------------- Template Haskell -------------------
-- THNames.hs: USES DataUniques 100-150
-----------------------------------------------------
@@ -2232,5 +2250,5 @@ pretendNameIsInScope :: Name -> Bool
pretendNameIsInScope n
= any (n `hasKey`)
[ starKindTyConKey, liftedTypeKindTyConKey, tYPETyConKey
- , unliftedTypeKindTyConKey, levityTyConKey, liftedDataConKey
- , unliftedDataConKey ]
+ , unliftedTypeKindTyConKey
+ , runtimeRepTyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey ]
diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs
index 66172acd24..7b37062aa4 100644
--- a/compiler/prelude/PrimOp.hs
+++ b/compiler/prelude/PrimOp.hs
@@ -30,7 +30,7 @@ import TysWiredIn
import CmmType
import Demand
import OccName ( OccName, pprOccName, mkVarOccFS )
-import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) )
+import TyCon ( TyCon, isPrimTyCon, PrimRep(..) )
import Type
import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..) )
import ForeignCall ( CLabelString )
diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs
index d1e42d5a10..ce25c308a1 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/prelude/TysPrim.hs
@@ -15,13 +15,11 @@ module TysPrim(
mkTemplateTyVars,
alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
alphaTys, alphaTy, betaTy, gammaTy, deltaTy,
- levity1TyVar, levity2TyVar, levity1Ty, levity2Ty,
+ runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty,
openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar,
kKiVar,
-- Kind constructors...
- tYPETyCon, unliftedTypeKindTyCon, unliftedTypeKind,
-
tYPETyConName, unliftedTypeKindTyConName,
-- Kinds
@@ -80,7 +78,18 @@ module TysPrim(
#include "HsVersions.h"
-import {-# SOURCE #-} TysWiredIn ( levityTy, unliftedDataConTy, liftedTypeKind )
+import {-# SOURCE #-} TysWiredIn
+ ( runtimeRepTy, liftedTypeKind
+ , vecRepDataConTyCon, ptrRepUnliftedDataConTyCon
+ , voidRepDataConTy, intRepDataConTy
+ , wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy
+ , floatRepDataConTy, doubleRepDataConTy
+ , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy
+ , vec64DataConTy
+ , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy
+ , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy
+ , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy
+ , doubleElemRepDataConTy )
import Var ( TyVar, KindVar, mkTyVar )
import Name
@@ -89,6 +98,7 @@ import SrcLoc
import Unique
import PrelNames
import FastString
+import Outputable
import TyCoRep -- doesn't need special access, but this is easier to avoid
-- import loops
@@ -228,17 +238,17 @@ alphaTys = mkTyVarTys alphaTyVars
alphaTy, betaTy, gammaTy, deltaTy :: Type
(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys
-levity1TyVar, levity2TyVar :: TyVar
-(levity1TyVar : levity2TyVar : _)
- = drop 21 (mkTemplateTyVars (repeat levityTy)) -- selects 'v','w'
+runtimeRep1TyVar, runtimeRep2TyVar :: TyVar
+(runtimeRep1TyVar : runtimeRep2TyVar : _)
+ = drop 16 (mkTemplateTyVars (repeat runtimeRepTy)) -- selects 'q','r'
-levity1Ty, levity2Ty :: Type
-levity1Ty = mkTyVarTy levity1TyVar
-levity2Ty = mkTyVarTy levity2TyVar
+runtimeRep1Ty, runtimeRep2Ty :: Type
+runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar
+runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar
openAlphaTyVar, openBetaTyVar :: TyVar
[openAlphaTyVar,openBetaTyVar]
- = mkTemplateTyVars [tYPE levity1Ty, tYPE levity2Ty]
+ = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty]
openAlphaTy, openBetaTy :: Type
openAlphaTy = mkTyVarTy openAlphaTyVar
@@ -260,9 +270,9 @@ funTyConName :: Name
funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
funTyCon :: TyCon
-funTyCon = mkFunTyCon funTyConName kind tc_rep_nm
+funTyCon = mkFunTyCon funTyConName (map Anon [liftedTypeKind, liftedTypeKind])
+ tc_rep_nm
where
- kind = mkFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind
-- You might think that (->) should have type (?? -> ? -> *), and you'd be right
-- But if we do that we get kind errors when saying
-- instance Control.Arrow (->)
@@ -274,20 +284,6 @@ funTyCon = mkFunTyCon funTyConName kind tc_rep_nm
tc_rep_nm = mkPrelTyConRepName funTyConName
--- One step to remove subkinding.
--- (->) :: * -> * -> *
--- but we should have (and want) the following typing rule for fully applied arrows
--- Gamma |- tau :: k1 k1 in {*, #}
--- Gamma |- sigma :: k2 k2 in {*, #, (#)}
--- -----------------------------------------
--- Gamma |- tau -> sigma :: *
--- Currently we have the following rule which achieves more or less the same effect
--- Gamma |- tau :: ??
--- Gamma |- sigma :: ?
--- --------------------------
--- Gamma |- tau -> sigma :: *
--- In the end we don't want subkinding at all.
-
{-
************************************************************************
* *
@@ -299,35 +295,48 @@ Note [TYPE]
~~~~~~~~~~~
There are a few places where we wish to be able to deal interchangeably
with kind * and kind #. unsafeCoerce#, error, and (->) are some of these
-places. The way we do this is to use levity polymorphism.
+places. The way we do this is to use runtime-representation polymorphism.
-We have (levityTyCon, liftedDataCon, unliftedDataCon)
+We have
- data Levity = Lifted | Unlifted
+ data RuntimeRep = PtrRepLifted | PtrRepUnlifted | ...
and a magical constant (tYPETyCon)
- TYPE :: Levity -> TYPE Lifted
+ TYPE :: RuntimeRep -> TYPE PtrRepLifted
We then have synonyms (liftedTypeKindTyCon, unliftedTypeKindTyCon)
- type Type = TYPE Lifted
- type # = TYPE Unlifted
+ type * = TYPE PtrRepLifted
+ type # = TYPE PtrRepUnlifted
+
+The (...) in the definition for RuntimeRep includes possibilities for
+the unboxed, unlifted representations, isomorphic to the PrimRep type
+in TyCon. RuntimeRep is itself declared in GHC.Types.
+
+An alternative design would be to have
+
+ data RuntimeRep = PtrRep Levity | ...
+ data Levity = Lifted | Unlifted
-So, for example, we get
+but this slowed down GHC because every time we looked at *, we had to
+follow a bunch of pointers. When we have unpackable sums, we should
+go back to the stratified representation. This would allow, for example:
- unsafeCoerce# :: forall (v1 :: Levity) (v2 :: Levity)
+ unsafeCoerce# :: forall (r1 :: RuntimeRep) (v2 :: Levity)
(a :: TYPE v1) (b :: TYPE v2). a -> b
-This replaces the old sub-kinding machinery. We call variables `a` and `b`
-above "levity polymorphic".
+TYPE replaces the old sub-kinding machinery. We call variables `a` and `b`
+above "runtime-representation polymorphic".
+
-}
tYPETyCon, unliftedTypeKindTyCon :: TyCon
tYPETyConName, unliftedTypeKindTyConName :: Name
tYPETyCon = mkKindTyCon tYPETyConName
- (ForAllTy (Anon levityTy) liftedTypeKind)
+ [Anon runtimeRepTy]
+ liftedTypeKind
[Nominal]
(mkPrelTyConRepName tYPETyConName)
@@ -335,9 +344,9 @@ tYPETyCon = mkKindTyCon tYPETyConName
-- NB: unlifted is wired in because there is no way to parse it in
-- Haskell. That's the only reason for wiring it in.
unliftedTypeKindTyCon = mkSynonymTyCon unliftedTypeKindTyConName
- liftedTypeKind
- [] []
- (tYPE unliftedDataConTy)
+ [] liftedTypeKind
+ [] []
+ (tYPE (TyConApp ptrRepUnliftedDataConTyCon []))
--------------------------
-- ... and now their names
@@ -347,9 +356,6 @@ unliftedTypeKindTyCon = mkSynonymTyCon unliftedTypeKindTyConName
tYPETyConName = mkPrimTyConName (fsLit "TYPE") tYPETyConKey tYPETyCon
unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
-unliftedTypeKind :: Kind
-unliftedTypeKind = tYPE unliftedDataConTy
-
mkPrimTyConName :: FastString -> Unique -> TyCon -> Name
mkPrimTyConName = mkPrimTcName BuiltInSyntax
-- All of the super kinds and kinds are defined in Prim,
@@ -360,9 +366,9 @@ mkPrimTcName built_in_syntax occ key tycon
= mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon tycon) built_in_syntax
-----------------------------
--- | Given a Levity, applies TYPE to it. See Note [TYPE].
+-- | Given a RuntimeRep, applies TYPE to it. See Note [TYPE].
tYPE :: Type -> Type
-tYPE lev = TyConApp tYPETyCon [lev]
+tYPE rr = TyConApp tYPETyCon [rr]
{-
************************************************************************
@@ -375,16 +381,48 @@ tYPE lev = TyConApp tYPETyCon [lev]
-- only used herein
pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon
pcPrimTyCon name roles rep
- = mkPrimTyCon name kind roles rep
+ = mkPrimTyCon name binders result_kind roles
where
- kind = mkFunTys (map (const liftedTypeKind) roles) result_kind
- result_kind = unliftedTypeKind
+ binders = map (const (Anon liftedTypeKind)) roles
+ result_kind = tYPE rr
+
+ rr = case rep of
+ VoidRep -> voidRepDataConTy
+ PtrRep -> TyConApp ptrRepUnliftedDataConTyCon []
+ IntRep -> intRepDataConTy
+ WordRep -> wordRepDataConTy
+ Int64Rep -> int64RepDataConTy
+ Word64Rep -> word64RepDataConTy
+ AddrRep -> addrRepDataConTy
+ FloatRep -> floatRepDataConTy
+ DoubleRep -> doubleRepDataConTy
+ VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem']
+ where
+ n' = case n of
+ 2 -> vec2DataConTy
+ 4 -> vec4DataConTy
+ 8 -> vec8DataConTy
+ 16 -> vec16DataConTy
+ 32 -> vec32DataConTy
+ 64 -> vec64DataConTy
+ _ -> pprPanic "Disallowed VecCount" (ppr n)
+
+ elem' = case elem of
+ Int8ElemRep -> int8ElemRepDataConTy
+ Int16ElemRep -> int16ElemRepDataConTy
+ Int32ElemRep -> int32ElemRepDataConTy
+ Int64ElemRep -> int64ElemRepDataConTy
+ Word8ElemRep -> word8ElemRepDataConTy
+ Word16ElemRep -> word16ElemRepDataConTy
+ Word32ElemRep -> word32ElemRepDataConTy
+ Word64ElemRep -> word64ElemRepDataConTy
+ FloatElemRep -> floatElemRepDataConTy
+ DoubleElemRep -> doubleElemRepDataConTy
+
pcPrimTyCon0 :: Name -> PrimRep -> TyCon
pcPrimTyCon0 name rep
- = mkPrimTyCon name result_kind [] rep
- where
- result_kind = unliftedTypeKind
+ = pcPrimTyCon name [] rep
charPrimTy :: Type
charPrimTy = mkTyConTy charPrimTyCon
@@ -627,7 +665,7 @@ RealWorld; it's only used in the type system, to parameterise State#.
-}
realWorldTyCon :: TyCon
-realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind [] PtrRep
+realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName [] liftedTypeKind []
realWorldTy :: Type
realWorldTy = mkTyConTy realWorldTyCon
realWorldStatePrimTy :: Type
@@ -647,11 +685,12 @@ mkProxyPrimTy :: Type -> Type -> Type
mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty]
proxyPrimTyCon :: TyCon
-proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName kind [Nominal,Nominal] VoidRep
- where kind = ForAllTy (Named kv Specified) $
- mkFunTy k unliftedTypeKind
- kv = kKiVar
- k = mkTyVarTy kv
+proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Nominal]
+ where binders = [ Named kv Specified
+ , Anon k ]
+ res_kind = tYPE voidRepDataConTy
+ kv = kKiVar
+ k = mkTyVarTy kv
{- *********************************************************************
@@ -663,10 +702,12 @@ proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName kind [Nominal,Nominal] VoidRep
eqPrimTyCon :: TyCon -- The representation type for equality predicates
-- See Note [The equality types story]
-eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind roles VoidRep
- where kind = ForAllTy (Named kv1 Specified) $
- ForAllTy (Named kv2 Specified) $
- mkFunTys [k1, k2] unliftedTypeKind
+eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles
+ where binders = [ Named kv1 Specified
+ , Named kv2 Specified
+ , Anon k1
+ , Anon k2 ]
+ res_kind = tYPE voidRepDataConTy
[kv1, kv2] = mkTemplateTyVars [liftedTypeKind, liftedTypeKind]
k1 = mkTyVarTy kv1
k2 = mkTyVarTy kv2
@@ -676,11 +717,12 @@ eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind roles VoidRep
-- this should only ever appear as the type of a covar. Its role is
-- interpreted in coercionRole
eqReprPrimTyCon :: TyCon -- See Note [The equality types story]
-eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName kind
- roles VoidRep
- where kind = ForAllTy (Named kv1 Specified) $
- ForAllTy (Named kv2 Specified) $
- mkFunTys [k1, k2] unliftedTypeKind
+eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles
+ where binders = [ Named kv1 Specified
+ , Named kv2 Specified
+ , Anon k1
+ , Anon k2 ]
+ res_kind = tYPE voidRepDataConTy
[kv1, kv2] = mkTemplateTyVars [liftedTypeKind, liftedTypeKind]
k1 = mkTyVarTy kv1
k2 = mkTyVarTy kv2
@@ -690,12 +732,13 @@ eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName kind
-- This is only used to make higher-order equalities. Nothing
-- should ever actually have this type!
eqPhantPrimTyCon :: TyCon
-eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName kind
+eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind
[Nominal, Nominal, Phantom, Phantom]
- VoidRep
- where kind = ForAllTy (Named kv1 Specified) $
- ForAllTy (Named kv2 Specified) $
- mkFunTys [k1, k2] unliftedTypeKind
+ where binders = [ Named kv1 Specified
+ , Named kv2 Specified
+ , Anon k1
+ , Anon k2 ]
+ res_kind = tYPE voidRepDataConTy
[kv1, kv2] = mkTemplateTyVars [liftedTypeKind, liftedTypeKind]
k1 = mkTyVarTy kv1
k2 = mkTyVarTy kv2
@@ -920,12 +963,13 @@ anyTy :: Type
anyTy = mkTyConTy anyTyCon
anyTyCon :: TyCon
-anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar] Nothing
+anyTyCon = mkFamilyTyCon anyTyConName binders res_kind [kKiVar] Nothing
(ClosedSynFamilyTyCon Nothing)
Nothing
NotInjective
where
- kind = ForAllTy (Named kKiVar Specified) (mkTyVarTy kKiVar)
+ binders = [Named kKiVar Specified]
+ res_kind = mkTyVarTy kKiVar
anyTypeOfKind :: Kind -> Type
anyTypeOfKind kind = TyConApp anyTyCon [kind]
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index b7bd186e86..6f0fc569f2 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -88,11 +88,25 @@ module TysWiredIn (
mkWiredInIdName, -- used in MkId
- -- * Levity
- levityTy, levityTyCon, liftedDataCon, unliftedDataCon,
- liftedPromDataCon, unliftedPromDataCon,
- liftedDataConTy, unliftedDataConTy,
- liftedDataConName, unliftedDataConName,
+ -- * RuntimeRep and friends
+ runtimeRepTyCon, vecCountTyCon, vecElemTyCon,
+
+ runtimeRepTy, ptrRepLiftedTy,
+
+ vecRepDataConTyCon, ptrRepUnliftedDataConTyCon,
+
+ voidRepDataConTy, intRepDataConTy,
+ wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy,
+ floatRepDataConTy, doubleRepDataConTy, unboxedTupleRepDataConTy,
+
+ vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
+ vec64DataConTy,
+
+ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
+ int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,
+ word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,
+ doubleElemRepDataConTy
+
) where
#include "HsVersions.h"
@@ -135,6 +149,15 @@ alpha_ty :: [Type]
alpha_ty = [alphaTy]
{-
+Note [Wiring in RuntimeRep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors,
+making it a pain to wire in. To ease the pain somewhat, we use lists of
+the different bits, like Uniques, Names, DataCons. These lists must be
+kept in sync with each other. The rule is this: use the order as declared
+in GHC.Types. All places where such lists exist should contain a reference
+to this Note, so a search for this Note's name should find all the lists.
+
************************************************************************
* *
\subsection{Wired in type constructors}
@@ -178,7 +201,9 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
, coercibleTyCon
, typeNatKindCon
, typeSymbolKindCon
- , levityTyCon
+ , runtimeRepTyCon
+ , vecCountTyCon
+ , vecElemTyCon
, constraintKindTyCon
, liftedTypeKindTyCon
, starKindTyCon
@@ -264,10 +289,48 @@ liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type")
starKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "*") starKindTyConKey starKindTyCon
unicodeStarKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "★") unicodeStarKindTyConKey unicodeStarKindTyCon
-levityTyConName, liftedDataConName, unliftedDataConName :: Name
-levityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Levity") levityTyConKey levityTyCon
-liftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted") liftedDataConKey liftedDataCon
-unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon
+runtimeRepTyConName, vecRepDataConName :: Name
+runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon
+vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon
+
+-- See Note [Wiring in RuntimeRep]
+runtimeRepSimpleDataConNames :: [Name]
+runtimeRepSimpleDataConNames
+ = zipWith3Lazy mk_special_dc_name
+ [ fsLit "PtrRepLifted", fsLit "PtrRepUnlifted"
+ , fsLit "VoidRep", fsLit "IntRep"
+ , fsLit "WordRep", fsLit "Int64Rep", fsLit "Word64Rep"
+ , fsLit "AddrRep", fsLit "FloatRep", fsLit "DoubleRep"
+ , fsLit "UnboxedTupleRep" ]
+ runtimeRepSimpleDataConKeys
+ runtimeRepSimpleDataCons
+
+vecCountTyConName :: Name
+vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon
+
+-- See Note [Wiring in RuntimeRep]
+vecCountDataConNames :: [Name]
+vecCountDataConNames = zipWith3Lazy mk_special_dc_name
+ [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8"
+ , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ]
+ vecCountDataConKeys
+ vecCountDataCons
+
+vecElemTyConName :: Name
+vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon
+
+-- See Note [Wiring in RuntimeRep]
+vecElemDataConNames :: [Name]
+vecElemDataConNames = zipWith3Lazy mk_special_dc_name
+ [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep"
+ , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16elemRep"
+ , fsLit "Word32ElemRep", fsLit "Word64ElemRep"
+ , fsLit "FloatElemRep", fsLit "DoubleElemRep" ]
+ vecElemDataConKeys
+ vecElemDataCons
+
+mk_special_dc_name :: FastString -> Unique -> DataCon -> Name
+mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc
parrTyConName, parrDataConName :: Name
parrTyConName = mkWiredInTyConName BuiltInSyntax
@@ -304,7 +367,8 @@ pcNonRecDataTyCon = pcTyCon False NonRecursive
pcTyCon :: Bool -> RecFlag -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcTyCon is_enum is_rec name cType tyvars cons
= mkAlgTyCon name
- (mkFunTys (map tyVarKind tyvars) liftedTypeKind)
+ (map (mkAnonBinder . tyVarKind) tyvars)
+ liftedTypeKind
tyvars
(map (const Representational) tyvars)
cType
@@ -325,6 +389,7 @@ pcDataConWithFixity :: Bool -- ^ declared infix?
-> TyCon
-> DataCon
pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique n))
+ NoRRI
-- The Name's unique is the first of two free uniques;
-- the first is used for the datacon itself,
-- the second is used for the "worker name"
@@ -332,12 +397,13 @@ pcDataConWithFixity infx n = pcDataConWithFixity' infx n (incrUnique (nameUnique
-- To support this the mkPreludeDataConUnique function "allocates"
-- one DataCon unique per pair of Ints.
-pcDataConWithFixity' :: Bool -> Name -> Unique -> [TyVar] -> [TyVar]
+pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo
+ -> [TyVar] -> [TyVar]
-> [Type] -> TyCon -> DataCon
-- The Name should be in the DataName name space; it's the name
-- of the DataCon itself.
-pcDataConWithFixity' declared_infix dc_name wrk_key tyvars ex_tyvars arg_tys tycon
+pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars arg_tys tycon
= data_con
where
data_con = mkDataCon dc_name declared_infix prom_info
@@ -348,6 +414,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars ex_tyvars arg_tys tyc
[] -- No equality spec
[] -- No theta
arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))
+ rri
tycon
[] -- No stupid theta
(mkDataConWorkId wrk_name data_con)
@@ -364,6 +431,12 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars ex_tyvars arg_tys tyc
prom_info = mkPrelTyConRepName dc_name
+-- used for RuntimeRep and friends
+pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon
+pcSpecialDataCon dc_name arg_tys tycon rri
+ = pcDataConWithFixity' False dc_name (incrUnique (nameUnique dc_name)) rri
+ [] [] arg_tys tycon
+
{-
************************************************************************
* *
@@ -387,7 +460,7 @@ constraintKindTyCon = pcTyCon False NonRecursive constraintKindTyConName
Nothing [] []
liftedTypeKind, constraintKind :: Kind
-liftedTypeKind = tYPE liftedDataConTy
+liftedTypeKind = tYPE ptrRepLiftedTy
constraintKind = mkTyConApp constraintKindTyCon []
@@ -536,34 +609,38 @@ unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mA
mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
mk_tuple boxity arity = (tycon, tuple_con)
where
- tycon = mkTupleTyCon tc_name tc_kind tc_arity tyvars tuple_con
+ tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tyvars tuple_con
tup_sort flavour
- (tup_sort, modu, tc_kind, tc_arity, tyvars, tyvar_tys, flavour)
+ (tup_sort, modu, tc_binders, tc_res_kind, tc_arity, tyvars, tyvar_tys, flavour)
= case boxity of
Boxed ->
let boxed_tyvars = take arity alphaTyVars in
( BoxedTuple
, gHC_TUPLE
- , mkFunTys (nOfThem arity liftedTypeKind) liftedTypeKind
+ , nOfThem arity (mkAnonBinder liftedTypeKind)
+ , liftedTypeKind
, arity
, boxed_tyvars
, mkTyVarTys boxed_tyvars
, VanillaAlgTyCon (mkPrelTyConRepName tc_name)
)
- -- See Note [Unboxed tuple levity vars] in TyCon
+ -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
Unboxed ->
- let all_tvs = mkTemplateTyVars (replicate arity levityTy ++
+ let all_tvs = mkTemplateTyVars (replicate arity runtimeRepTy ++
map (tYPE . mkTyVarTy) (take arity all_tvs))
-- NB: This must be one call to mkTemplateTyVars, to make
-- sure that all the uniques are different
- (lev_tvs, open_tvs) = splitAt arity all_tvs
+ (rr_tvs, open_tvs) = splitAt arity all_tvs
+ res_rep | arity == 0 = voidRepDataConTy
+ -- See Note [Nullary unboxed tuple] in Type
+ | otherwise = unboxedTupleRepDataConTy
in
( UnboxedTuple
, gHC_PRIM
- , mkSpecForAllTys lev_tvs $
- mkFunTys (map tyVarKind open_tvs) $
- unliftedTypeKind
+ , map (mkNamedBinder Specified) rr_tvs ++
+ map (mkAnonBinder . tyVarKind) open_tvs
+ , tYPE res_rep
, arity * 2
, all_tvs
, mkTyVarTys open_tvs
@@ -616,13 +693,16 @@ heqSCSelId, coercibleSCSelId :: Id
(heqTyCon, heqClass, heqDataCon, heqSCSelId)
= (tycon, klass, datacon, sc_sel_id)
where
- tycon = mkClassTyCon heqTyConName kind tvs roles
+ tycon = mkClassTyCon heqTyConName binders tvs roles
rhs klass NonRecursive
(mkPrelTyConRepName heqTyConName)
klass = mkClass tvs [] [sc_pred] [sc_sel_id] [] [] (mkAnd []) tycon
datacon = pcDataCon heqDataConName tvs [sc_pred] tycon
- kind = mkSpecForAllTys [kv1, kv2] $ mkFunTys [k1, k2] constraintKind
+ binders = [ mkNamedBinder Specified kv1
+ , mkNamedBinder Specified kv2
+ , mkAnonBinder k1
+ , mkAnonBinder k2 ]
kv1:kv2:_ = drop 9 alphaTyVars -- gets "j" and "k"
k1 = mkTyVarTy kv1
k2 = mkTyVarTy kv2
@@ -637,13 +717,15 @@ heqSCSelId, coercibleSCSelId :: Id
(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId)
= (tycon, klass, datacon, sc_sel_id)
where
- tycon = mkClassTyCon coercibleTyConName kind tvs roles
+ tycon = mkClassTyCon coercibleTyConName binders tvs roles
rhs klass NonRecursive
(mkPrelTyConRepName coercibleTyConName)
klass = mkClass tvs [] [sc_pred] [sc_sel_id] [] [] (mkAnd []) tycon
datacon = pcDataCon coercibleDataConName tvs [sc_pred] tycon
- kind = mkSpecForAllTys [kKiVar] $ mkFunTys [k, k] constraintKind
+ binders = [ mkNamedBinder Specified kKiVar
+ , mkAnonBinder k
+ , mkAnonBinder k ]
k = mkTyVarTy kKiVar
[av,bv] = mkTemplateTyVars [k, k]
tvs = [kKiVar, av, bv]
@@ -656,48 +738,125 @@ heqSCSelId, coercibleSCSelId :: Id
{- *********************************************************************
* *
- Kinds and levity
+ Kinds and RuntimeRep
* *
********************************************************************* -}
-- For information about the usage of the following type, see Note [TYPE]
-- in module TysPrim
-levityTy :: Type
-levityTy = mkTyConTy levityTyCon
-
-levityTyCon :: TyCon
-levityTyCon = pcTyCon True NonRecursive levityTyConName
- Nothing [] [liftedDataCon, unliftedDataCon]
-
-liftedDataCon, unliftedDataCon :: DataCon
-liftedDataCon = pcDataCon liftedDataConName [] [] levityTyCon
-unliftedDataCon = pcDataCon unliftedDataConName [] [] levityTyCon
-
-liftedPromDataCon, unliftedPromDataCon :: TyCon
-liftedPromDataCon = promoteDataCon liftedDataCon
-unliftedPromDataCon = promoteDataCon unliftedDataCon
-
-liftedDataConTy, unliftedDataConTy :: Type
-liftedDataConTy = mkTyConTy liftedPromDataCon
-unliftedDataConTy = mkTyConTy unliftedPromDataCon
+runtimeRepTy :: Type
+runtimeRepTy = mkTyConTy runtimeRepTyCon
liftedTypeKindTyCon, starKindTyCon, unicodeStarKindTyCon :: TyCon
-- See Note [TYPE] in TysPrim
liftedTypeKindTyCon = mkSynonymTyCon liftedTypeKindTyConName
- liftedTypeKind
+ [] liftedTypeKind
[] []
- (tYPE liftedDataConTy)
+ (tYPE ptrRepLiftedTy)
starKindTyCon = mkSynonymTyCon starKindTyConName
- liftedTypeKind
+ [] liftedTypeKind
[] []
- (tYPE liftedDataConTy)
+ (tYPE ptrRepLiftedTy)
unicodeStarKindTyCon = mkSynonymTyCon unicodeStarKindTyConName
- liftedTypeKind
+ [] liftedTypeKind
[] []
- (tYPE liftedDataConTy)
+ (tYPE ptrRepLiftedTy)
+
+runtimeRepTyCon :: TyCon
+runtimeRepTyCon = pcNonRecDataTyCon runtimeRepTyConName Nothing []
+ (vecRepDataCon : runtimeRepSimpleDataCons)
+
+vecRepDataCon :: DataCon
+vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon
+ , mkTyConTy vecElemTyCon ]
+ runtimeRepTyCon
+ (RuntimeRep prim_rep_fun)
+ where
+ prim_rep_fun [count, elem]
+ | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count)
+ , VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem)
+ = VecRep n e
+ prim_rep_fun args
+ = pprPanic "vecRepDataCon" (ppr args)
+
+vecRepDataConTyCon :: TyCon
+vecRepDataConTyCon = promoteDataCon vecRepDataCon
+
+ptrRepUnliftedDataConTyCon :: TyCon
+ptrRepUnliftedDataConTyCon = promoteDataCon ptrRepUnliftedDataCon
+
+-- See Note [Wiring in RuntimeRep]
+runtimeRepSimpleDataCons :: [DataCon]
+ptrRepLiftedDataCon, ptrRepUnliftedDataCon :: DataCon
+runtimeRepSimpleDataCons@(ptrRepLiftedDataCon : ptrRepUnliftedDataCon : _)
+ = zipWithLazy mk_runtime_rep_dc
+ [ PtrRep, PtrRep, VoidRep, IntRep, WordRep, Int64Rep
+ , Word64Rep, AddrRep, FloatRep, DoubleRep
+ , panic "unboxed tuple PrimRep" ]
+ runtimeRepSimpleDataConNames
+ where
+ mk_runtime_rep_dc primrep name
+ = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> primrep))
+
+-- See Note [Wiring in RuntimeRep]
+voidRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy,
+ word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy,
+ unboxedTupleRepDataConTy :: Type
+[_, _, voidRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy,
+ word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy,
+ unboxedTupleRepDataConTy] = map (mkTyConTy . promoteDataCon)
+ runtimeRepSimpleDataCons
+
+vecCountTyCon :: TyCon
+vecCountTyCon = pcNonRecDataTyCon vecCountTyConName Nothing []
+ vecCountDataCons
+
+-- See Note [Wiring in RuntimeRep]
+vecCountDataCons :: [DataCon]
+vecCountDataCons = zipWithLazy mk_vec_count_dc
+ [ 2, 4, 8, 16, 32, 64 ]
+ vecCountDataConNames
+ where
+ mk_vec_count_dc n name
+ = pcSpecialDataCon name [] vecCountTyCon (VecCount n)
+
+-- See Note [Wiring in RuntimeRep]
+vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
+ vec64DataConTy :: Type
+[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
+ vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons
+
+vecElemTyCon :: TyCon
+vecElemTyCon = pcNonRecDataTyCon vecElemTyConName Nothing [] vecElemDataCons
+
+-- See Note [Wiring in RuntimeRep]
+vecElemDataCons :: [DataCon]
+vecElemDataCons = zipWithLazy mk_vec_elem_dc
+ [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep
+ , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep
+ , FloatElemRep, DoubleElemRep ]
+ vecElemDataConNames
+ where
+ mk_vec_elem_dc elem name
+ = pcSpecialDataCon name [] vecElemTyCon (VecElem elem)
+
+-- See Note [Wiring in RuntimeRep]
+int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
+ int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,
+ word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,
+ doubleElemRepDataConTy :: Type
+[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
+ int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,
+ word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,
+ doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon)
+ vecElemDataCons
+
+-- The type ('PtrRepLifted)
+ptrRepLiftedTy :: Type
+ptrRepLiftedTy = mkTyConTy $ promoteDataCon ptrRepLiftedDataCon
{- *********************************************************************
* *
@@ -943,13 +1102,13 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}.
-}
-- | Make a tuple type. The list of types should /not/ include any
--- levity specifications.
+-- RuntimeRep specifications.
mkTupleTy :: Boxity -> [Type] -> Type
-- Special case for *boxed* 1-tuples, which are represented by the type itself
mkTupleTy Boxed [ty] = ty
mkTupleTy Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys
mkTupleTy Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys))
- (map (getLevity "mkTupleTy") tys ++ tys)
+ (map (getRuntimeRep "mkTupleTy") tys ++ tys)
-- | Build the type of a small tuple that holds the specified type of thing
mkBoxedTupleTy :: [Type] -> Type
diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot
index f7ae6354b3..7216d2667c 100644
--- a/compiler/prelude/TysWiredIn.hs-boot
+++ b/compiler/prelude/TysWiredIn.hs-boot
@@ -1,6 +1,6 @@
module TysWiredIn where
-import TyCon
+import {-# SOURCE #-} TyCon ( TyCon )
import {-# SOURCE #-} TyCoRep (Type, Kind)
@@ -8,6 +8,22 @@ listTyCon :: TyCon
typeNatKind, typeSymbolKind :: Type
mkBoxedTupleTy :: [Type] -> Type
-levityTy, unliftedDataConTy :: Type
-
liftedTypeKind :: Kind
+constraintKind :: Kind
+
+runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon
+runtimeRepTy :: Type
+
+ptrRepUnliftedDataConTyCon, vecRepDataConTyCon :: TyCon
+
+voidRepDataConTy, intRepDataConTy,
+ wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy,
+ floatRepDataConTy, doubleRepDataConTy, unboxedTupleRepDataConTy :: Type
+
+vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
+ vec64DataConTy :: Type
+
+int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,
+ int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,
+ word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,
+ doubleElemRepDataConTy :: Type
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index b3da5ef5ea..498687efb2 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -14,6 +14,8 @@ module Inst (
instCall, instDFunType, instStupidTheta,
newWanted, newWanteds,
+ tcInstBinders, tcInstBindersX,
+
newOverloadedLit, mkOverLit,
newClsInst,
@@ -30,7 +32,7 @@ module Inst (
#include "HsVersions.h"
import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp )
-import {-# SOURCE #-} TcUnify( unifyType, noThing )
+import {-# SOURCE #-} TcUnify( unifyType, unifyKind, noThing )
import FastString
import HsSyn
@@ -39,8 +41,7 @@ import TcRnMonad
import TcEnv
import TcEvidence
import InstEnv
-import DataCon ( dataConWrapId )
-import TysWiredIn ( heqDataCon )
+import TysWiredIn ( heqDataCon, coercibleDataCon )
import CoreSyn ( isOrphan )
import FunDeps
import TcMType
@@ -51,7 +52,9 @@ import Class( Class )
import MkId( mkDictFunId )
import Id
import Name
-import Var ( EvVar )
+import Var ( EvVar, mkTyVar )
+import DataCon
+import TyCon
import VarEnv
import PrelNames
import SrcLoc
@@ -329,6 +332,122 @@ instStupidTheta orig theta
{-
************************************************************************
* *
+ Instantiating Kinds
+* *
+************************************************************************
+
+-}
+
+---------------------------
+-- | This is used to instantiate binders when type-checking *types* only.
+-- See also Note [Bidirectional type checking]
+tcInstBinders :: [TyBinder] -> TcM (TCvSubst, [TcType])
+tcInstBinders = tcInstBindersX emptyTCvSubst Nothing
+
+-- | This is used to instantiate binders when type-checking *types* only.
+-- The @VarEnv Kind@ gives some known instantiations.
+-- See also Note [Bidirectional type checking]
+tcInstBindersX :: TCvSubst -> Maybe (VarEnv Kind)
+ -> [TyBinder] -> TcM (TCvSubst, [TcType])
+tcInstBindersX subst mb_kind_info bndrs
+ = do { (subst, args) <- mapAccumLM (tcInstBinderX mb_kind_info) subst bndrs
+ ; traceTc "instantiating tybinders:"
+ (vcat $ zipWith (\bndr arg -> ppr bndr <+> text ":=" <+> ppr arg)
+ bndrs args)
+ ; return (subst, args) }
+
+-- | Used only in *types*
+tcInstBinderX :: Maybe (VarEnv Kind)
+ -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
+tcInstBinderX mb_kind_info subst binder
+ | Just tv <- binderVar_maybe binder
+ = case lookup_tv tv of
+ Just ki -> return (extendTvSubstAndInScope subst tv ki, ki)
+ Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv
+ ; return (subst', mkTyVarTy tv') }
+
+ -- This is the *only* constraint currently handled in types.
+ | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty
+ = do { let origin = TypeEqOrigin { uo_actual = k1
+ , uo_expected = mkCheckExpType k2
+ , uo_thing = Nothing }
+ ; co <- case role of
+ Nominal -> unifyKind noThing k1 k2
+ Representational -> emitWantedEq origin KindLevel role k1 k2
+ Phantom -> pprPanic "tcInstBinderX Phantom" (ppr binder)
+ ; arg' <- mk co k1 k2
+ ; return (subst, arg') }
+
+ | isPredTy substed_ty
+ = do { let (env, tidy_ty) = tidyOpenType emptyTidyEnv substed_ty
+ ; addErrTcM (env, text "Illegal constraint in a type:" <+> ppr tidy_ty)
+
+ -- just invent a new variable so that we can continue
+ ; u <- newUnique
+ ; let name = mkSysTvName u (fsLit "dict")
+ ; return (subst, mkTyVarTy $ mkTyVar name substed_ty) }
+
+
+ | otherwise
+ = do { ty <- newFlexiTyVarTy substed_ty
+ ; return (subst, ty) }
+
+ where
+ substed_ty = substTy subst (binderType binder)
+
+ lookup_tv tv = do { env <- mb_kind_info -- `Maybe` monad
+ ; lookupVarEnv env tv }
+
+ -- handle boxed equality constraints, because it's so easy
+ get_pred_tys_maybe ty
+ | Just (r, k1, k2) <- getEqPredTys_maybe ty
+ = Just (\co _ _ -> return $ mkCoercionTy co, r, k1, k2)
+ | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
+ = if | tc `hasKey` heqTyConKey
+ -> Just (mkHEqBoxTy, Nominal, k1, k2)
+ | otherwise
+ -> Nothing
+ | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
+ = if | tc `hasKey` eqTyConKey
+ -> Just (mkEqBoxTy, Nominal, k1, k2)
+ | tc `hasKey` coercibleTyConKey
+ -> Just (mkCoercibleBoxTy, Representational, k1, k2)
+ | otherwise
+ -> Nothing
+ | otherwise
+ = Nothing
+
+-------------------------------
+-- | This takes @a ~# b@ and returns @a ~~ b@.
+mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
+-- monadic just for convenience with mkEqBoxTy
+mkHEqBoxTy co ty1 ty2
+ = return $
+ mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]
+ where k1 = typeKind ty1
+ k2 = typeKind ty2
+
+-- | This takes @a ~# b@ and returns @a ~ b@.
+mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
+mkEqBoxTy co ty1 ty2
+ = do { eq_tc <- tcLookupTyCon eqTyConName
+ ; let [datacon] = tyConDataCons eq_tc
+ ; hetero <- mkHEqBoxTy co ty1 ty2
+ ; return $ mkTyConApp (promoteDataCon datacon) [k, ty1, ty2, hetero] }
+ where k = typeKind ty1
+
+-- | This takes @a ~R# b@ and returns @Coercible a b@.
+mkCoercibleBoxTy :: TcCoercion -> Type -> Type -> TcM Type
+-- monadic just for convenience with mkEqBoxTy
+mkCoercibleBoxTy co ty1 ty2
+ = do { return $
+ mkTyConApp (promoteDataCon coercibleDataCon)
+ [k, ty1, ty2, mkCoercionTy co] }
+ where k = typeKind ty1
+
+{-
+************************************************************************
+* *
Literals
* *
************************************************************************
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 43f933b70d..495a442fa1 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -963,7 +963,7 @@ recoveryCode binder_names sig_fn
= mkLocalId name forall_a_a
forall_a_a :: TcType
-forall_a_a = mkSpecForAllTys [levity1TyVar, openAlphaTyVar] openAlphaTy
+forall_a_a = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] openAlphaTy
{- *********************************************************************
* *
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 75996f8163..2da3153c3c 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -1134,7 +1134,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
-- the following makes a better distinction between "kind" and "type"
-- in error messages
- (bndrs, _) = splitPiTys (tyConKind tc)
+ bndrs = tyConBinders tc
kind_loc = toKindLoc loc
is_kinds = map isNamedBinder bndrs
new_locs | Just KindLevel <- ctLocTypeOrKind_maybe loc
@@ -1962,10 +1962,8 @@ unify_derived loc role orig_ty1 orig_ty2
Nothing -> bale_out }
go _ _ = bale_out
- -- no point in having *boxed* deriveds.
bale_out = emitNewDerivedEq loc role orig_ty1 orig_ty2
maybeSym :: SwapFlag -> TcCoercion -> TcCoercion
maybeSym IsSwapped co = mkTcSymCo co
maybeSym NotSwapped co = co
-
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 56772f2b1a..c2b344dd77 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -934,7 +934,7 @@ inferConstraints main_cls cls_tys inst_ty rep_tc rep_tc_args
++ sc_constraints
++ arg_constraints) }
where
- (tc_binders, _) = splitPiTys (tyConKind rep_tc)
+ tc_binders = tyConBinders rep_tc
choose_level bndr
| isNamedBinder bndr = KindLevel
| otherwise = TypeLevel
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 2140a797ff..daae2021e8 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -29,8 +29,8 @@ import DataCon
import TcEvidence
import Name
import RdrName ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual )
-import PrelNames ( typeableClassName, hasKey
- , liftedDataConKey, unliftedDataConKey )
+import PrelNames ( typeableClassName, hasKey, ptrRepLiftedDataConKey
+ , ptrRepUnliftedDataConKey )
import Id
import Var
import VarSet
@@ -1366,12 +1366,22 @@ misMatchMsg ct oriented ty1 ty2
| Just NotSwapped <- oriented
= misMatchMsg ct (Just IsSwapped) ty2 ty1
+ -- These next two cases are when we're about to report, e.g., that
+ -- 'PtrRepLifted doesn't match 'VoidRep. Much better just to say
+ -- lifted vs. unlifted
+ | Just (tc1, []) <- splitTyConApp_maybe ty1
+ , tc1 `hasKey` ptrRepLiftedDataConKey
+ = lifted_vs_unlifted
+
+ | Just (tc2, []) <- splitTyConApp_maybe ty2
+ , tc2 `hasKey` ptrRepLiftedDataConKey
+ = lifted_vs_unlifted
+
| Just (tc1, []) <- splitTyConApp_maybe ty1
, Just (tc2, []) <- splitTyConApp_maybe ty2
- , (tc1 `hasKey` liftedDataConKey && tc2 `hasKey` unliftedDataConKey) ||
- (tc2 `hasKey` liftedDataConKey && tc1 `hasKey` unliftedDataConKey)
- = addArising orig $
- text "Couldn't match a lifted type with an unlifted type"
+ , (tc1 `hasKey` ptrRepLiftedDataConKey && tc2 `hasKey` ptrRepUnliftedDataConKey)
+ || (tc1 `hasKey` ptrRepUnliftedDataConKey && tc2 `hasKey` ptrRepLiftedDataConKey)
+ = lifted_vs_unlifted
| otherwise -- So now we have Nothing or (Just IsSwapped)
-- For some reason we treat Nothing like IsSwapped
@@ -1406,6 +1416,10 @@ misMatchMsg ct oriented ty1 ty2
| null s2 = s1
| otherwise = s1 ++ (' ' : s2)
+ lifted_vs_unlifted
+ = addArising orig $
+ text "Couldn't match a lifted type with an unlifted type"
+
mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool
-> (Bool, Maybe SwapFlag, SDoc)
-- NotSwapped means (actual, expected), IsSwapped is the reverse
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index d54fbc7644..6d5fe09bb9 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -361,7 +361,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
; arg2' <- tcArg op arg2 arg2_sigma 2
-- Make sure that the argument type has kind '*'
- -- ($) :: forall (v:Levity) (a:*) (b:TYPE v). (a->b) -> a -> b
+ -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b
-- Eg we do not want to allow (D# $ 4.0#) Trac #5570
-- (which gives a seg fault)
--
@@ -378,7 +378,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
; op_id <- tcLookupId op_name
; res_ty <- readExpType res_ty
- ; let op' = L loc (HsWrap (mkWpTyApps [ getLevity "tcExpr ($)" res_ty
+ ; let op' = L loc (HsWrap (mkWpTyApps [ getRuntimeRep "tcExpr ($)" res_ty
, arg2_sigma
, res_ty])
(HsVar (L lv op_id)))
@@ -443,9 +443,9 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
tup_tc = tupleTyCon boxity arity
; res_ty <- expTypeToType res_ty
; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
- -- Unboxed tuples have levity vars, which we
+ -- Unboxed tuples have RuntimeRep vars, which we
-- don't care about here
- -- See Note [Unboxed tuple levity vars] in TyCon
+ -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys
Boxed -> arg_tys
; tup_args1 <- tcTupArgs tup_args arg_tys'
@@ -1663,8 +1663,8 @@ tcSeq loc fun_name args res_ty
; (arg1, arg2, arg2_exp_ty) <- case args1 of
[ty_arg_expr2, term_arg1, term_arg2]
| Just hs_ty_arg2 <- isLHsTypeExpr_maybe ty_arg_expr2
- -> do { lev_ty <- newFlexiTyVarTy levityTy
- ; ty_arg2 <- tcHsTypeApp hs_ty_arg2 (tYPE lev_ty)
+ -> do { rr_ty <- newFlexiTyVarTy runtimeRepTy
+ ; ty_arg2 <- tcHsTypeApp hs_ty_arg2 (tYPE rr_ty)
-- see Note [Typing rule for seq]
; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg2 res_ty
; return (term_arg1, term_arg2, mkCheckExpType ty_arg2) }
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 66fe38ad8f..d7d23a2a81 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -9,7 +9,7 @@ This module is an extension of @HsSyn@ syntax, for use in the type
checker.
-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, TupleSections #-}
module TcHsSyn (
mkHsConApp, mkHsDictLet, mkHsApp,
@@ -29,7 +29,7 @@ module TcHsSyn (
zonkTopBndrs, zonkTyBndrsX,
emptyZonkEnv, mkEmptyZonkEnv,
zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
- zonkCoToCo
+ zonkCoToCo, zonkTcKindToKind
) where
#include "HsVersions.h"
@@ -44,6 +44,7 @@ import TcEvidence
import TysPrim
import TysWiredIn
import Type
+import TyCoRep ( TyBinder(..) )
import Coercion
import ConLike
import DataCon
@@ -328,6 +329,15 @@ zonkTyBndrX env tv
; let tv' = mkTyVar (tyVarName tv) ki
; return (extendTyZonkEnv1 env tv', tv') }
+zonkTyBinders :: ZonkEnv -> [TcTyBinder] -> TcM (ZonkEnv, [TyBinder])
+zonkTyBinders = mapAccumLM zonkTyBinder
+
+zonkTyBinder :: ZonkEnv -> TcTyBinder -> TcM (ZonkEnv, TyBinder)
+zonkTyBinder env (Anon ty) = (env, ) <$> (Anon <$> zonkTcTypeToType env ty)
+zonkTyBinder env (Named tv vis)
+ = do { (env', tv') <- zonkTyBndrX env tv
+ ; return (env', Named tv' vis) }
+
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
zonkTopExpr e = zonkExpr emptyZonkEnv e
@@ -1582,6 +1592,14 @@ zonkTcTypeToType = mapType zonk_tycomapper
zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
+-- | Used during kind-checking in TcTyClsDecls, where it's more convenient
+-- to keep the binders and result kind separate.
+zonkTcKindToKind :: [TcTyBinder] -> TcKind -> TcM ([TyBinder], Kind)
+zonkTcKindToKind binders res_kind
+ = do { (env, binders') <- zonkTyBinders emptyZonkEnv binders
+ ; res_kind' <- zonkTcTypeToType env res_kind
+ ; return (binders', res_kind') }
+
zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
zonkCoToCo = mapCoercion zonk_tycomapper
@@ -1604,7 +1622,7 @@ zonkTypeZapping :: UnboundTyVarZonker
-- It zaps unbound type variables to (), or some other arbitrary type
-- Works on both types and kinds
zonkTypeZapping tv
- = do { let ty | isLevityVar tv = liftedDataConTy
- | otherwise = anyTypeOfKind (tyVarKind tv)
+ = do { let ty | isRuntimeRepVar tv = ptrRepLiftedTy
+ | otherwise = anyTypeOfKind (tyVarKind tv)
; writeMetaTyVar tv ty
; return ty }
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index c7b1470ab1..5b0d9b9e8c 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -54,6 +54,7 @@ import TcUnify
import TcIface
import TcSimplify ( solveEqualities )
import TcType
+import Inst ( tcInstBinders, tcInstBindersX )
import Type
import Kind
import RdrName( lookupLocalRdrOcc )
@@ -185,8 +186,8 @@ tcHsSigType ctxt sig_ty
do { kind <- case expectedKindInCtxt ctxt of
AnythingKind -> newMetaKindVar
TheKind k -> return k
- OpenKind -> do { lev <- newFlexiTyVarTy levityTy
- ; return $ tYPE lev }
+ OpenKind -> do { rr <- newFlexiTyVarTy runtimeRepTy
+ ; return $ tYPE rr }
-- The kind is checked by checkValidType, and isn't necessarily
-- of kind * in a Template Haskell quote eg [t| Maybe |]
@@ -459,10 +460,10 @@ tc_lhs_type mode (L span ty) exp_kind
------------------------------------------
tc_fun_type :: TcTyMode -> LHsType Name -> LHsType Name -> TcKind -> TcM TcType
tc_fun_type mode ty1 ty2 exp_kind
- = do { arg_lev <- newFlexiTyVarTy levityTy
- ; res_lev <- newFlexiTyVarTy levityTy
- ; ty1' <- tc_lhs_type mode ty1 (tYPE arg_lev)
- ; ty2' <- tc_lhs_type mode ty2 (tYPE res_lev)
+ = do { arg_rr <- newFlexiTyVarTy runtimeRepTy
+ ; res_rr <- newFlexiTyVarTy runtimeRepTy
+ ; ty1' <- tc_lhs_type mode ty1 (tYPE arg_rr)
+ ; ty2' <- tc_lhs_type mode ty2 (tYPE res_rr)
; checkExpectedKind (mkFunTy ty1' ty2') liftedTypeKind exp_kind }
------------------------------------------
@@ -657,8 +658,8 @@ tc_tuple :: TcTyMode -> TupleSort -> [LHsType Name] -> TcKind -> TcM TcType
tc_tuple mode tup_sort tys exp_kind
= do { arg_kinds <- case tup_sort of
BoxedTuple -> return (nOfThem arity liftedTypeKind)
- UnboxedTuple -> do { levs <- newFlexiTyVarTys arity levityTy
- ; return $ map tYPE levs }
+ UnboxedTuple -> do { rrs <- newFlexiTyVarTys arity runtimeRepTy
+ ; return $ map tYPE rrs }
ConstraintTuple -> return (nOfThem arity constraintKind)
; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds
; finish_tuple tup_sort tau_tys arg_kinds exp_kind }
@@ -673,8 +674,8 @@ finish_tuple :: TupleSort
finish_tuple tup_sort tau_tys tau_kinds exp_kind
= do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind)
; let arg_tys = case tup_sort of
- -- See also Note [Unboxed tuple levity vars] in TyCon
- UnboxedTuple -> map (getLevityFromKind "finish_tuple") tau_kinds
+ -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon
+ UnboxedTuple -> map (getRuntimeRepFromKind "finish_tuple") tau_kinds
++ tau_tys
BoxedTuple -> tau_tys
ConstraintTuple -> tau_tys
@@ -691,7 +692,7 @@ finish_tuple tup_sort tau_tys tau_kinds exp_kind
where
arity = length tau_tys
res_kind = case tup_sort of
- UnboxedTuple -> unliftedTypeKind
+ UnboxedTuple -> tYPE unboxedTupleRepDataConTy
BoxedTuple -> liftedTypeKind
ConstraintTuple -> constraintKind
@@ -712,19 +713,21 @@ bigConstraintTuple arity
-- the visible ones.
tcInferArgs :: Outputable fun
=> fun -- ^ the function
- -> TcKind -- ^ function kind (zonked)
+ -> [TyBinder] -- ^ function kind's binders
-> Maybe (VarEnv Kind) -- ^ possibly, kind info (see above)
-> [LHsType Name] -- ^ args
- -> TcM (TcKind, [TcType], [LHsType Name], Int)
- -- ^ (result kind, typechecked args, untypechecked args, n)
-tcInferArgs fun fun_kind mb_kind_info args
- = do { (res_kind, args', leftovers, n)
- <- tc_infer_args typeLevelMode fun fun_kind mb_kind_info args 1
+ -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType Name], Int)
+ -- ^ (instantiating subst, un-insted leftover binders,
+ -- typechecked args, untypechecked args, n)
+tcInferArgs fun binders mb_kind_info args
+ = do { (subst, leftover_binders, args', leftovers, n)
+ <- tc_infer_args typeLevelMode fun binders mb_kind_info args 1
-- now, we need to instantiate any remaining invisible arguments
- ; let (invis_bndrs, really_res_kind) = splitPiTysInvisible res_kind
- ; (subst, invis_args)
- <- tcInstBindersX emptyTCvSubst mb_kind_info invis_bndrs
- ; return ( substTy subst really_res_kind
+ ; let (invis_bndrs, other_binders) = span isInvisibleBinder leftover_binders
+ ; (subst', invis_args)
+ <- tcInstBindersX subst mb_kind_info invis_bndrs
+ ; return ( subst'
+ , other_binders
, args' `chkAppend` invis_args
, leftovers, n ) }
@@ -733,48 +736,40 @@ tcInferArgs fun fun_kind mb_kind_info args
tc_infer_args :: Outputable fun
=> TcTyMode
-> fun -- ^ the function
- -> TcKind -- ^ function kind (zonked)
+ -> [TyBinder] -- ^ function kind's binders (zonked)
-> Maybe (VarEnv Kind) -- ^ possibly, kind info (see above)
-> [LHsType Name] -- ^ args
-> Int -- ^ number to start arg counter at
- -> TcM (TcKind, [TcType], [LHsType Name], Int)
-tc_infer_args mode orig_ty ki mb_kind_info orig_args n0
- = do { traceTc "tcInferApps" (ppr ki $$ ppr orig_args)
- ; go emptyTCvSubst ki orig_args n0 [] }
+ -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType Name], Int)
+tc_infer_args mode orig_ty binders mb_kind_info orig_args n0
+ = do { traceTc "tcInferApps" (ppr binders $$ ppr orig_args)
+ ; go emptyTCvSubst binders orig_args n0 [] }
where
- go subst fun_kind [] n acc
- = return ( substTyUnchecked subst fun_kind, reverse acc, [], n )
+ go subst binders [] n acc
+ = return ( subst, binders, reverse acc, [], n )
-- when we call this when checking type family patterns, we really
-- do want to instantiate all invisible arguments. During other
-- typechecking, we don't.
- go subst fun_kind all_args n acc
- | Just fun_kind' <- coreView fun_kind
- = go subst fun_kind' all_args n acc
+ go subst binders all_args n acc
+ | (inv_binders, other_binders) <- span isInvisibleBinder binders
+ , not (null inv_binders)
+ = do { (subst', args') <- tcInstBindersX subst mb_kind_info inv_binders
+ ; go subst' other_binders all_args n (reverse args' ++ acc) }
- | Just tv <- getTyVar_maybe fun_kind
- , Just fun_kind' <- lookupTyVar subst tv
- = go subst fun_kind' all_args n acc
-
- | (inv_bndrs, res_k) <- splitPiTysInvisible fun_kind
- , not (null inv_bndrs)
- = do { (subst', args') <- tcInstBindersX subst mb_kind_info inv_bndrs
- ; go subst' res_k all_args n (reverse args' ++ acc) }
-
- | Just (bndr, res_k) <- splitPiTy_maybe fun_kind
- , arg:args <- all_args -- this actually has to succeed
- = ASSERT( isVisibleBinder bndr )
- do { let mode' | isNamedBinder bndr = kindLevel mode
- | otherwise = mode
+ go subst (binder:binders) (arg:args) n acc
+ = ASSERT( isVisibleBinder binder )
+ do { let mode' | isNamedBinder binder = kindLevel mode
+ | otherwise = mode
; arg' <- addErrCtxt (funAppCtxt orig_ty arg n) $
- tc_lhs_type mode' arg (substTyUnchecked subst $ binderType bndr)
- ; let subst' = case binderVar_maybe bndr of
+ tc_lhs_type mode' arg (substTyUnchecked subst $ binderType binder)
+ ; let subst' = case binderVar_maybe binder of
Just tv -> extendTvSubst subst tv arg'
Nothing -> subst
- ; go subst' res_k args (n+1) (arg' : acc) }
+ ; go subst' binders args (n+1) (arg' : acc) }
- | otherwise
- = return (substTy subst fun_kind, reverse acc, all_args, n)
+ go subst [] all_args n acc
+ = return (subst, [], reverse acc, all_args, n)
-- | Applies a type to a list of arguments. Always consumes all the
-- arguments.
@@ -789,13 +784,13 @@ tcInferApps mode orig_ty ty ki args = go ty ki args 1
where
go fun fun_kind [] _ = return (fun, fun_kind)
go fun fun_kind args n
- | Just fun_kind' <- coreView fun_kind
- = go fun fun_kind' args n
-
- | isPiTy fun_kind
- = do { (res_kind, args', leftover_args, n')
- <- tc_infer_args mode orig_ty fun_kind Nothing args n
- ; go (mkNakedAppTys fun args') res_kind leftover_args n' }
+ | let (binders, res_kind) = splitPiTys fun_kind
+ , not (null binders)
+ = do { (subst, leftover_binders, args', leftover_args, n')
+ <- tc_infer_args mode orig_ty binders Nothing args n
+ ; let fun_kind' = substTyUnchecked subst $
+ mkForAllTys leftover_binders res_kind
+ ; go (mkNakedAppTys fun args') fun_kind' leftover_args n' }
go fun fun_kind all_args@(arg:args) n
= do { (co, arg_k, res_k) <- matchExpectedFunKind (length all_args)
@@ -805,110 +800,6 @@ tcInferApps mode orig_ty ty ki args = go ty ki args 1
; go (mkNakedAppTy (fun `mkNakedCastTy` co) arg')
res_k args (n+1) }
----------------------------
--- | This is used to instantiate binders when type-checking *types* only.
--- Precondition: all binders are invisible. See also Note [Bidirectional type checking]
-tcInstBinders :: [TyBinder] -> TcM (TCvSubst, [TcType])
-tcInstBinders = tcInstBindersX emptyTCvSubst Nothing
-
--- | This is used to instantiate binders when type-checking *types* only.
--- Precondition: all binders are invisible.
--- The @VarEnv Kind@ gives some known instantiations.
--- See also Note [Bidirectional type checking]
-tcInstBindersX :: TCvSubst -> Maybe (VarEnv Kind)
- -> [TyBinder] -> TcM (TCvSubst, [TcType])
-tcInstBindersX subst mb_kind_info bndrs
- = do { (subst, args) <- mapAccumLM (tcInstBinderX mb_kind_info) subst bndrs
- ; traceTc "instantiating implicit dependent vars:"
- (vcat $ zipWith (\bndr arg -> ppr bndr <+> text ":=" <+> ppr arg)
- bndrs args)
- ; return (subst, args) }
-
--- | Used only in *types*
-tcInstBinderX :: Maybe (VarEnv Kind)
- -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
-tcInstBinderX mb_kind_info subst binder
- | Just tv <- binderVar_maybe binder
- = case lookup_tv tv of
- Just ki -> return (extendTvSubstAndInScope subst tv ki, ki)
- Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv
- ; return (subst', mkTyVarTy tv') }
-
- -- This is the *only* constraint currently handled in types.
- | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty
- = do { let origin = TypeEqOrigin { uo_actual = k1
- , uo_expected = mkCheckExpType k2
- , uo_thing = Nothing }
- ; co <- case role of
- Nominal -> unifyKind noThing k1 k2
- Representational -> emitWantedEq origin KindLevel role k1 k2
- Phantom -> pprPanic "tcInstBinderX Phantom" (ppr binder)
- ; arg' <- mk co k1 k2
- ; return (subst, arg') }
-
- | otherwise
- = do { let (env, tidy_ty) = tidyOpenType emptyTidyEnv substed_ty
- ; addErrTcM (env, text "Illegal constraint in a type:" <+> ppr tidy_ty)
-
- -- just invent a new variable so that we can continue
- ; u <- newUnique
- ; let name = mkSysTvName u (fsLit "dict")
- ; return (subst, mkTyVarTy $ mkTyVar name substed_ty) }
-
- where
- substed_ty = substTy subst (binderType binder)
-
- lookup_tv tv = do { env <- mb_kind_info -- `Maybe` monad
- ; lookupVarEnv env tv }
-
- -- handle boxed equality constraints, because it's so easy
- get_pred_tys_maybe ty
- | Just (r, k1, k2) <- getEqPredTys_maybe ty
- = Just (\co _ _ -> return $ mkCoercionTy co, r, k1, k2)
- | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
- = if | tc `hasKey` heqTyConKey
- -> Just (mkHEqBoxTy, Nominal, k1, k2)
- | otherwise
- -> Nothing
- | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
- = if | tc `hasKey` eqTyConKey
- -> Just (mkEqBoxTy, Nominal, k1, k2)
- | tc `hasKey` coercibleTyConKey
- -> Just (mkCoercibleBoxTy, Representational, k1, k2)
- | otherwise
- -> Nothing
- | otherwise
- = Nothing
-
--------------------------------
--- | This takes @a ~# b@ and returns @a ~~ b@.
-mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
--- monadic just for convenience with mkEqBoxTy
-mkHEqBoxTy co ty1 ty2
- = return $
- mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]
- where k1 = typeKind ty1
- k2 = typeKind ty2
-
--- | This takes @a ~# b@ and returns @a ~ b@.
-mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
-mkEqBoxTy co ty1 ty2
- = do { eq_tc <- tcLookupTyCon eqTyConName
- ; let [datacon] = tyConDataCons eq_tc
- ; hetero <- mkHEqBoxTy co ty1 ty2
- ; return $ mkTyConApp (promoteDataCon datacon) [k, ty1, ty2, hetero] }
- where k = typeKind ty1
-
--- | This takes @a ~R# b@ and returns @Coercible a b@.
-mkCoercibleBoxTy :: TcCoercion -> Type -> Type -> TcM Type
--- monadic just for convenience with mkEqBoxTy
-mkCoercibleBoxTy co ty1 ty2
- = do { return $
- mkTyConApp (promoteDataCon coercibleDataCon)
- [k, ty1, ty2, mkCoercionTy co] }
- where k = typeKind ty1
-
-
--------------------------
checkExpectedKind :: TcType -- the type whose kind we're checking
-> TcKind -- the known kind of that type, k
@@ -1283,7 +1174,8 @@ kcHsTyVarBndrs :: Bool -- ^ True <=> the decl being checked has a CUSK
-> ([TyVar] -> [TyVar] -> TcM (Kind, r))
-- ^ the result kind, possibly with other info
-- ^ args are implicit vars, explicit vars
- -> TcM (Kind, r) -- ^ The full kind of the thing being declared,
+ -> TcM ([TcTyBinder], TcKind, r)
+ -- ^ The full kind of the thing being declared,
-- with the other info
kcHsTyVarBndrs cusk (HsQTvs { hsq_implicit = kv_ns
, hsq_explicit = hs_tvs }) thing_inside
@@ -1293,9 +1185,9 @@ kcHsTyVarBndrs cusk (HsQTvs { hsq_implicit = kv_ns
-- the names must line up in splitTelescopeTvs
else zipWithM newSigTyVar kv_ns meta_kvs
; tcExtendTyVarEnv2 (kv_ns `zip` kvs) $
- do { (full_kind, _, stuff) <- bind_telescope hs_tvs (thing_inside kvs)
+ do { (binders, res_kind, _, stuff) <- bind_telescope hs_tvs (thing_inside kvs)
; let qkvs = filter (not . isMetaTyVar) $
- tyCoVarsOfTypeWellScoped full_kind
+ tyCoVarsOfTypeWellScoped (mkForAllTys binders res_kind)
-- these have to be the vars made with new_skolem_tv
-- above. Thus, they are known to the user and should
-- be Specified, not Invisible, when kind-generalizing
@@ -1303,28 +1195,28 @@ kcHsTyVarBndrs cusk (HsQTvs { hsq_implicit = kv_ns
-- the free non-meta variables in the returned kind will
-- contain both *mentioned* kind vars and *unmentioned* kind
-- vars (See case (1) under Note [Typechecking telescopes])
- gen_kind = if cusk
- then mkSpecForAllTys qkvs $ full_kind
- else full_kind
- ; return (gen_kind, stuff) } }
+ all_binders = if cusk
+ then map (mkNamedBinder Specified) qkvs ++ binders
+ else binders
+ ; return (all_binders, res_kind, stuff) } }
where
-- there may be dependency between the explicit "ty" vars. So, we have
- -- to handle them one at a time. We also need to build up a full kind
- -- here, because this is the place we know whether to use a FunTy or a
- -- ForAllTy. We prefer using an anonymous binder over a trivial named
+ -- to handle them one at a time. We also produce the TyBinders here,
+ -- because this is the place we know whether to use Anon or Named.
+ -- We prefer using an anonymous binder over a trivial named
-- binder. If a user wants a trivial named one, use an explicit kind
-- signature.
bind_telescope :: [LHsTyVarBndr Name]
-> ([TyVar] -> TcM (Kind, r))
- -> TcM (Kind, VarSet, r)
+ -> TcM ([TcTyBinder], TcKind, VarSet, r)
bind_telescope [] thing
= do { (res_kind, stuff) <- thing []
- ; return (res_kind, tyCoVarsOfType res_kind, stuff) }
+ ; return ([], res_kind, tyCoVarsOfType res_kind, stuff) }
bind_telescope (L _ hs_tv : hs_tvs) thing
= do { tv_pair@(tv, _) <- kc_hs_tv hs_tv
- ; (res_kind, fvs, stuff) <- bind_unless_scoped tv_pair $
- bind_telescope hs_tvs $ \tvs ->
- thing (tv:tvs)
+ ; (binders, res_kind, fvs, stuff) <- bind_unless_scoped tv_pair $
+ bind_telescope hs_tvs $ \tvs ->
+ thing (tv:tvs)
-- we must be *lazy* in res_kind and fvs (assuming that the
-- caller of kcHsTyVarBndrs is, too), as sometimes these hold
-- panics. See kcConDecl.
@@ -1337,7 +1229,7 @@ kcHsTyVarBndrs cusk (HsQTvs { hsq_implicit = kv_ns
| otherwise
= (mkAnonBinder k, fvs `unionVarSet` k_fvs)
- ; return ( mkForAllTy bndr res_kind, fvs', stuff ) }
+ ; return (bndr : binders, res_kind, fvs', stuff ) }
-- | Bind the tyvar in the env't unless the bool is True
bind_unless_scoped :: (TcTyVar, Bool) -> TcM a -> TcM a
@@ -1650,30 +1542,28 @@ are kind vars the didn't link up in splitTelescopeTvs.
-- Extend the env with bindings for the tyvars, taken from
-- the kind of the tycon/class. Give it to the thing inside, and
-- check the result kind matches
-kcLookupKind :: Name -> TcM Kind
+kcLookupKind :: Name -> TcM ([TyBinder], Kind)
kcLookupKind nm
= do { tc_ty_thing <- tcLookup nm
; case tc_ty_thing of
- ATcTyCon tc -> return (tyConKind tc)
- AGlobal (ATyCon tc) -> return (tyConKind tc)
+ ATcTyCon tc -> return (tyConBinders tc, tyConResKind tc)
+ AGlobal (ATyCon tc) -> return (tyConBinders tc, tyConResKind tc)
_ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) }
-- See Note [Typechecking telescopes]
-splitTelescopeTvs :: Kind -- of the head of the telescope
+splitTelescopeTvs :: [TyBinder] -- telescope binders
-> LHsQTyVars Name
-> ( [TyVar] -- scoped type variables
, NameSet -- ungeneralized implicit variables (case 2a)
, [TyVar] -- implicit type variables (cases 1 & 2)
, [TyVar] -- explicit type variables (cases 3 & 4)
- , [(LHsKind Name, Kind)] -- see Note [Tiresome kind matching]
- , Kind ) -- result kind
-splitTelescopeTvs kind tvbs@(HsQTvs { hsq_implicit = hs_kvs
- , hsq_explicit = hs_tvs })
- = let (bndrs, inner_ki) = splitPiTys kind
- (scoped_tvs, non_cusk_imp_names, imp_tvs, exp_tvs, kind_matches, mk_kind)
+ , [(LHsKind Name, Kind)] ) -- see Note [Tiresome kind matching]
+splitTelescopeTvs bndrs tvbs@(HsQTvs { hsq_implicit = hs_kvs
+ , hsq_explicit = hs_tvs })
+ = let (scoped_tvs, non_cusk_imp_names, imp_tvs, exp_tvs, kind_matches)
= mk_tvs [] [] bndrs (mkNameSet hs_kvs) hs_tvs
in
- (scoped_tvs, non_cusk_imp_names, imp_tvs, exp_tvs, kind_matches, mk_kind inner_ki)
+ (scoped_tvs, non_cusk_imp_names, imp_tvs, exp_tvs, kind_matches)
where
mk_tvs :: [TyVar] -- scoped tv accum (reversed)
-> [TyVar] -- implicit tv accum (reversed)
@@ -1684,8 +1574,7 @@ splitTelescopeTvs kind tvbs@(HsQTvs { hsq_implicit = hs_kvs
, NameSet -- Case 2a names
, [TyVar] -- implicit tyvars
, [TyVar] -- explicit tyvars
- , [(LHsKind Name, Kind)] -- tiresome kind matches
- , Type -> Type ) -- a function to create the result k
+ , [(LHsKind Name, Kind)] ) -- tiresome kind matches
mk_tvs scoped_tv_acc imp_tv_acc (bndr : bndrs) all_hs_kvs all_hs_tvs
| Just tv <- binderVar_maybe bndr
, isInvisibleBinder bndr
@@ -1703,9 +1592,9 @@ splitTelescopeTvs kind tvbs@(HsQTvs { hsq_implicit = hs_kvs
-- a non-CUSK. The kinds *aren't* generalized, so we won't see them
-- here.
mk_tvs scoped_tv_acc imp_tv_acc all_bndrs all_hs_kvs all_hs_tvs
- = let (scoped, exp_tvs, kind_matches, mk_kind)
+ = let (scoped, exp_tvs, kind_matches)
= mk_tvs2 scoped_tv_acc [] [] all_bndrs all_hs_tvs in
- (scoped, all_hs_kvs, reverse imp_tv_acc, exp_tvs, kind_matches, mk_kind)
+ (scoped, all_hs_kvs, reverse imp_tv_acc, exp_tvs, kind_matches)
-- no more Case (1) or (2)
-- This can't handle Case (1) or Case (2) from [Typechecking telescopes]
@@ -1716,8 +1605,7 @@ splitTelescopeTvs kind tvbs@(HsQTvs { hsq_implicit = hs_kvs
-> [LHsTyVarBndr Name]
-> ( [TyVar]
, [TyVar] -- explicit tvs only
- , [(LHsKind Name, Kind)] -- tiresome kind matches
- , Type -> Type )
+ , [(LHsKind Name, Kind)] ) -- tiresome kind matches
mk_tvs2 scoped_tv_acc exp_tv_acc kind_match_acc (bndr : bndrs) (hs_tv : hs_tvs)
| Just tv <- binderVar_maybe bndr
= ASSERT2( isVisibleBinder bndr, err_doc )
@@ -1733,7 +1621,6 @@ splitTelescopeTvs kind tvbs@(HsQTvs { hsq_implicit = hs_kvs
where
err_doc = vcat [ ppr (bndr : bndrs)
, ppr (hs_tv : hs_tvs)
- , ppr kind
, ppr tvbs ]
kind_match_acc' = case hs_tv of
@@ -1741,11 +1628,10 @@ splitTelescopeTvs kind tvbs@(HsQTvs { hsq_implicit = hs_kvs
L _ (KindedTyVar _ hs_kind) -> (hs_kind, kind) : kind_match_acc
where kind = binderType bndr
- mk_tvs2 scoped_tv_acc exp_tv_acc kind_match_acc all_bndrs [] -- All done!
+ mk_tvs2 scoped_tv_acc exp_tv_acc kind_match_acc [] [] -- All done!
= ( reverse scoped_tv_acc
, reverse exp_tv_acc
- , kind_match_acc -- no need to reverse; it's not ordered
- , mkForAllTys all_bndrs )
+ , kind_match_acc ) -- no need to reverse; it's not ordered
mk_tvs2 _ _ _ all_bndrs all_hs_tvs
= pprPanic "splitTelescopeTvs 2" (vcat [ ppr all_bndrs
@@ -1762,18 +1648,18 @@ kcTyClTyVars :: Name -- ^ of the tycon
-> LHsQTyVars Name
-> TcM a -> TcM a
kcTyClTyVars tycon hs_tvs thing_inside
- = do { kind <- kcLookupKind tycon
- ; let (scoped_tvs, non_cusk_kv_name_set, all_kvs, all_tvs, _, res_k)
- = splitTelescopeTvs kind hs_tvs
+ = do { (binders, res_kind) <- kcLookupKind tycon
+ ; let (scoped_tvs, non_cusk_kv_name_set, all_kvs, all_tvs, _)
+ = splitTelescopeTvs binders hs_tvs
; traceTc "kcTyClTyVars splitTelescopeTvs:"
(vcat [ text "Tycon:" <+> ppr tycon
- , text "Kind:" <+> ppr kind
+ , text "Binders:" <+> ppr binders
+ , text "res_kind:" <+> ppr res_kind
, text "hs_tvs:" <+> ppr hs_tvs
, text "scoped tvs:" <+> pprWithCommas pprTvBndr scoped_tvs
, text "implicit tvs:" <+> pprWithCommas pprTvBndr all_kvs
, text "explicit tvs:" <+> pprWithCommas pprTvBndr all_tvs
- , text "non-CUSK kvs:" <+> ppr non_cusk_kv_name_set
- , text "res_k:" <+> ppr res_k] )
+ , text "non-CUSK kvs:" <+> ppr non_cusk_kv_name_set ] )
-- need to look up the non-cusk kvs in order to get their
-- kinds right, in case the kinds were informed by
@@ -1799,7 +1685,7 @@ kcTyClTyVars tycon hs_tvs thing_inside
thing_inside }
tcTyClTyVars :: Name -> LHsQTyVars Name -- LHS of the type or class decl
- -> ([TyVar] -> [TyVar] -> Kind -> Kind -> TcM a) -> TcM a
+ -> ([TyVar] -> [TyVar] -> [TyBinder] -> Kind -> TcM a) -> TcM a
-- ^ Used for the type variables of a type or class decl
-- on the second full pass (type-checking/desugaring) in TcTyClDecls.
-- This is *not* used in the initial-kind run, nor in the "kind-checking" pass.
@@ -1807,7 +1693,7 @@ tcTyClTyVars :: Name -> LHsQTyVars Name -- LHS of the type or class decl
-- (tcTyClTyVars T [a,b] thing_inside)
-- where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> *
-- calls thing_inside with arguments
--- [k1,k2] [a,b] (forall (k1:*) (k2:*) (a:k1 -> *) (b:k1). k2 -> *) (k2 -> *)
+-- [k1,k2] [a,b] [k1:*, k2:*, a:k1 -> *, b:k1] (k2 -> *)
-- having also extended the type environment with bindings
-- for k1,k2,a,b
--
@@ -1816,27 +1702,27 @@ tcTyClTyVars :: Name -> LHsQTyVars Name -- LHS of the type or class decl
-- The LHsTyVarBndrs is always user-written, and the full, generalised
-- kind of the tycon is available in the local env.
tcTyClTyVars tycon hs_tvs thing_inside
- = do { kind <- kcLookupKind tycon
+ = do { (binders, res_kind) <- kcLookupKind tycon
; let ( scoped_tvs, float_kv_name_set, all_kvs
- , all_tvs, kind_matches, res_k )
- = splitTelescopeTvs kind hs_tvs
+ , all_tvs, kind_matches )
+ = splitTelescopeTvs binders hs_tvs
; traceTc "tcTyClTyVars splitTelescopeTvs:"
(vcat [ text "Tycon:" <+> ppr tycon
- , text "Kind:" <+> ppr kind
+ , text "Binders:" <+> ppr binders
+ , text "res_kind:" <+> ppr res_kind
, text "hs_tvs:" <+> ppr hs_tvs
, text "scoped tvs:" <+> pprWithCommas pprTvBndr scoped_tvs
, text "implicit tvs:" <+> pprWithCommas pprTvBndr all_kvs
, text "explicit tvs:" <+> pprWithCommas pprTvBndr all_tvs
, text "floating kvs:" <+> ppr float_kv_name_set
- , text "Tiresome kind matches:" <+> ppr kind_matches
- , text "res_k:" <+> ppr res_k] )
+ , text "Tiresome kind matches:" <+> ppr kind_matches ] )
; float_kvs <- deal_with_float_kvs float_kv_name_set kind_matches
scoped_tvs all_tvs
; tcExtendTyVarEnv (float_kvs ++ scoped_tvs) $
-- the float_kvs are already in the all_kvs
- thing_inside all_kvs all_tvs kind res_k }
+ thing_inside all_kvs all_tvs binders res_kind }
where
-- See Note [Free-floating kind vars]
deal_with_float_kvs float_kv_name_set kind_matches scoped_tvs all_tvs
@@ -1879,13 +1765,15 @@ tcTyClTyVars tycon hs_tvs thing_inside
2 (pprTvBndrs all_tvs) ]
-----------------------------------
-tcDataKindSig :: Kind -> TcM [TyVar]
+tcDataKindSig :: Kind -> TcM ([TyVar], [TyBinder], Kind)
-- GADT decls can have a (perhaps partial) kind signature
-- e.g. data T :: * -> * -> * where ...
-- This function makes up suitable (kinded) type variables for
-- the argument kinds, and checks that the result kind is indeed *.
-- We use it also to make up argument type variables for for data instances.
-- Never emits constraints.
+-- Returns the new TyVars, the extracted TyBinders, and the new, reduced
+-- result kind (which should always be Type or a synonym thereof)
tcDataKindSig kind
= do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind)
; span <- getSrcSpanM
@@ -1897,8 +1785,9 @@ tcDataKindSig kind
, isNothing (lookupLocalRdrOcc rdr_env occ) ]
-- Note [Avoid name clashes for associated data types]
- ; return [ mk_tv span uniq occ kind
- | ((kind, occ), uniq) <- arg_kinds `zip` occs `zip` uniqs ] }
+ ; return ( [ mk_tv span uniq occ kind
+ | ((kind, occ), uniq) <- arg_kinds `zip` occs `zip` uniqs ]
+ , bndrs, res_kind ) }
where
(bndrs, res_kind) = splitPiTys kind
arg_kinds = map binderType bndrs
@@ -2121,8 +2010,8 @@ in-scope variables that it should not unify with, but it's fiddly.
-- | Produce an 'TcKind' suitable for a checking a type that can be * or #.
ekOpen :: TcM TcKind
-ekOpen = do { lev <- newFlexiTyVarTy levityTy
- ; return (tYPE lev) }
+ekOpen = do { rr <- newFlexiTyVarTy runtimeRepTy
+ ; return (tYPE rr) }
unifyKinds :: [(TcType, TcKind)] -> TcM ([TcType], TcKind)
unifyKinds act_kinds
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 82c66cc953..460089e457 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -684,12 +684,13 @@ tcDataFamInstDecl mb_clsinfo
axiom_name eta_tvs [] fam_tc eta_pats
(mkTyConApp rep_tc (mkTyVarTys eta_tvs))
parent = DataFamInstTyCon axiom fam_tc pats'
- rep_tc_kind = mkPiTypesPreferFunTy full_tvs liftedTypeKind
+ ty_binders = mkTyBindersPreferAnon full_tvs liftedTypeKind
+
-- NB: Use the full_tvs from the pats. See bullet toward
-- the end of Note [Data type families] in TyCon
rep_tc = mkAlgTyCon rep_tc_name
- rep_tc_kind
+ ty_binders liftedTypeKind
full_tvs
(map (const Nominal) full_tvs)
(fmap unLoc cType) stupid_theta
@@ -1275,7 +1276,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags)
error_fun = L inst_loc $
wrapId (mkWpTyApps
- [ getLevity "tcInstanceMethods.tc_default" meth_tau
+ [ getRuntimeRep "tcInstanceMethods.tc_default" meth_tau
, meth_tau])
nO_METHOD_BINDING_ERROR_ID
error_msg dflags = L inst_loc (HsLit (HsStringPrim ""
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index b7a96d9f63..90f7243b25 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -2027,7 +2027,7 @@ onlyNamedBndrsApplied tc ks
= all isNamedBinder used_bndrs &&
not (any isNamedBinder leftover_bndrs)
where
- (bndrs, _) = splitPiTys (tyConKind tc)
+ bndrs = tyConBinders tc
(used_bndrs, leftover_bndrs) = splitAtList ks bndrs
doTyApp :: Class -> Type -> Type -> KindOrType -> TcS LookupInstResult
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index d058107cc9..e8c120ddbb 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -70,7 +70,7 @@ module TcMType (
zonkTcTyVar, zonkTcTyVars, zonkTyCoVarsAndFV, zonkTcTypeAndFV,
zonkQuantifiedTyVar, zonkQuantifiedTyVarOrType, quantifyTyVars,
defaultKindVar,
- zonkTcTyCoVarBndr, zonkTcType, zonkTcTypes, zonkCo,
+ zonkTcTyCoVarBndr, zonkTcTyBinder, zonkTcType, zonkTcTypes, zonkCo,
zonkTyCoVarKind, zonkTcTypeMapper,
zonkEvVar, zonkWC, zonkSimples, zonkId, zonkCt, zonkSkolemInfo,
@@ -330,10 +330,10 @@ test gadt/gadt-escape1.
-- | Make an 'ExpType' suitable for inferring a type of kind * or #.
newOpenInferExpType :: TcM ExpType
newOpenInferExpType
- = do { lev <- newFlexiTyVarTy levityTy
+ = do { rr <- newFlexiTyVarTy runtimeRepTy
; u <- newUnique
; tclvl <- getTcLevel
- ; let ki = tYPE lev
+ ; let ki = tYPE rr
; traceTc "newOpenInferExpType" (ppr u <+> dcolon <+> ppr ki)
; ref <- newMutVar Nothing
; return (Infer u tclvl ki ref) }
@@ -549,7 +549,6 @@ newFskTyVar fam_ty
= do { uniq <- newUnique
; let name = mkSysTvName uniq (fsLit "fsk")
; return (mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty)) }
-
{-
Note [Kind substitution when instantiating]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -754,8 +753,8 @@ newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)
-- | Create a tyvar that can be a lifted or unlifted type.
newOpenFlexiTyVarTy :: TcM TcType
newOpenFlexiTyVarTy
- = do { lev <- newFlexiTyVarTy levityTy
- ; newFlexiTyVarTy (tYPE lev) }
+ = do { rr <- newFlexiTyVarTy runtimeRepTy
+ ; newFlexiTyVarTy (tYPE rr) }
newMetaSigTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
newMetaSigTyVars = mapAccumLM newMetaSigTyVarX emptyTCvSubst
@@ -904,15 +903,15 @@ zonkQuantifiedTyVar :: TcTyVar -> TcM (Maybe TcTyVar)
--
-- This returns a tyvar if it should be quantified over; otherwise,
-- it returns Nothing. Nothing is
--- returned only if zonkQuantifiedTyVar is passed a Levity meta-tyvar,
--- in order to default to Lifted.
+-- returned only if zonkQuantifiedTyVar is passed a RuntimeRep meta-tyvar,
+-- in order to default to PtrRepLifted.
zonkQuantifiedTyVar tv = left_only `liftM` zonkQuantifiedTyVarOrType tv
where left_only :: Either a b -> Maybe a
left_only (Left x) = Just x
left_only (Right _) = Nothing
-- | Like zonkQuantifiedTyVar, but if zonking reveals that the tyvar
--- should become a type (when defaulting a levity var to Lifted), it
+-- should become a type (when defaulting a RuntimeRep var to PtrRepLifted), it
-- returns the type instead.
zonkQuantifiedTyVarOrType :: TcTyVar -> TcM (Either TcTyVar TcType)
zonkQuantifiedTyVarOrType tv
@@ -931,19 +930,19 @@ zonkQuantifiedTyVarOrType tv
Flexi -> return ()
Indirect ty -> WARN( True, ppr tv $$ ppr ty )
return ()
- if isLevityVar tv
- then do { writeMetaTyVar tv liftedDataConTy
- ; return (Right liftedDataConTy) }
+ if isRuntimeRepVar tv
+ then do { writeMetaTyVar tv ptrRepLiftedTy
+ ; return (Right ptrRepLiftedTy) }
else Left `liftM` skolemiseUnboundMetaTyVar tv vanillaSkolemTv
_other -> pprPanic "zonkQuantifiedTyVar" (ppr tv) -- FlatSkol, RuntimeUnk
-- | Take an (unconstrained) meta tyvar and default it. Works only for
--- kind vars (of type BOX) and levity vars (of type Levity).
+-- kind vars (of type *) and RuntimeRep vars (of type RuntimeRep).
defaultKindVar :: TcTyVar -> TcM Kind
defaultKindVar kv
| ASSERT( isMetaTyVar kv )
- isLevityVar kv
- = writeMetaTyVar kv liftedDataConTy >> return liftedDataConTy
+ isRuntimeRepVar kv
+ = writeMetaTyVar kv ptrRepLiftedTy >> return ptrRepLiftedTy
| otherwise
= writeMetaTyVar kv liftedTypeKind >> return liftedTypeKind
@@ -1283,6 +1282,11 @@ zonkTcTyCoVarBndr tyvar
= ASSERT2( isImmutableTyVar tyvar || (not $ isTyVar tyvar), ppr tyvar ) do
updateTyVarKindM zonkTcType tyvar
+-- | Zonk a TyBinder
+zonkTcTyBinder :: TcTyBinder -> TcM TcTyBinder
+zonkTcTyBinder (Anon ty) = Anon <$> zonkTcType ty
+zonkTcTyBinder (Named tv vis) = Named <$> zonkTcTyCoVarBndr tv <*> pure vis
+
zonkTcTyVar :: TcTyVar -> TcM TcType
-- Simply look through all Flexis
zonkTcTyVar tv
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index 4d1d09a32f..bd769bfe29 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -458,8 +458,8 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside
tc = tupleTyCon boxity arity
; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
penv pat_ty
- -- Unboxed tuples have levity vars, which we discard:
- -- See Note [Unboxed tuple levity vars] in TyCon
+ -- Unboxed tuples have RuntimeRep vars, which we discard:
+ -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
Boxed -> arg_tys
; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys)
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 1e833242cb..b627cd4a2e 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -19,7 +19,7 @@ import TcRnMonad
import TcEnv
import TcMType
import TysPrim
-import TysWiredIn ( levityTy )
+import TysWiredIn ( runtimeRepTy )
import Name
import SrcLoc
import PatSyn
@@ -463,13 +463,13 @@ tcPatSynMatcher has_sig (L loc name) lpat
(univ_tvs, req_theta, req_ev_binds, req_dicts)
(ex_tvs, ex_tys, prov_theta, prov_dicts)
(args, arg_tys) pat_ty
- = do { lev_uniq <- newUnique
- ; tv_uniq <- newUnique
- ; let lev_name = mkInternalName lev_uniq (mkTyVarOcc "rlev") loc
+ = do { rr_uniq <- newUnique
+ ; tv_uniq <- newUnique
+ ; let rr_name = mkInternalName rr_uniq (mkTyVarOcc "rep") loc
tv_name = mkInternalName tv_uniq (mkTyVarOcc "r") loc
- lev_tv = mkTcTyVar lev_name levityTy (SkolemTv False)
- lev = mkTyVarTy lev_tv
- res_tv = mkTcTyVar tv_name (tYPE lev) (SkolemTv False)
+ rr_tv = mkTcTyVar rr_name runtimeRepTy (SkolemTv False)
+ rr = mkTyVarTy rr_tv
+ res_tv = mkTcTyVar tv_name (tYPE rr) (SkolemTv False)
is_unlifted = null args && null prov_dicts
res_ty = mkTyVarTy res_tv
(cont_args, cont_arg_tys)
@@ -487,7 +487,7 @@ tcPatSynMatcher has_sig (L loc name) lpat
; fail <- newSysLocalId (fsLit "fail") fail_ty
; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
- matcher_sigma = mkInvSigmaTy (lev_tv:res_tv:univ_tvs) req_theta matcher_tau
+ matcher_sigma = mkInvSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
matcher_id = mkExportedVanillaId matcher_name matcher_sigma
-- See Note [Exported LocalIds] in Id
@@ -517,7 +517,7 @@ tcPatSynMatcher has_sig (L loc name) lpat
, mg_res_ty = res_ty
, mg_origin = Generated
}
- match = mkMatch [] (mkHsLams (lev_tv:res_tv:univ_tvs) req_dicts body')
+ match = mkMatch [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body')
(noLoc EmptyLocalBinds)
mg = MG{ mg_alts = L (getLoc match) [match]
, mg_arg_tys = []
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index fdc6e5e638..a2a04e9bde 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1915,7 +1915,7 @@ tcGhciStmts stmts
(noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ;
mk_item id = let ty_args = [idType id, unitTy] in
nlHsApp (nlHsTyApp unsafeCoerceId
- (map (getLevity "tcGhciStmts") ty_args ++ ty_args))
+ (map (getRuntimeRep "tcGhciStmts") ty_args ++ ty_args))
(nlHsVar id) ;
stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
} ;
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 053c53b86a..4e5cceb07a 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -929,9 +929,9 @@ Note [Flavours with roles]
~~~~~~~~~~~~~~~~~~~~~~~~~~
The system described in Note [inert_eqs: the inert equalities]
discusses an abstract
-set of flavours. In GHC, flavours have three components: the flavour proper,
-taken from {Wanted, Derived, Given}; the equality relation (often called
-role), taken from {NomEq, ReprEq}; and the levity, taken from {Lifted, Unlifted}.
+set of flavours. In GHC, flavours have two components: the flavour proper,
+taken from {Wanted, Derived, Given} and the equality relation (often called
+role), taken from {NomEq, ReprEq}.
When substituting w.r.t. the inert set,
as described in Note [inert_eqs: the inert equalities],
we must be careful to respect all components of a flavour.
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index be0735816b..a19ceaa39d 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -37,7 +37,7 @@ import TcSMonad as TcS
import TcType
import TrieMap () -- DV: for now
import Type
-import TysWiredIn ( liftedDataConTy )
+import TysWiredIn ( ptrRepLiftedTy )
import Unify ( tcMatchTy )
import Util
import Var
@@ -1488,24 +1488,24 @@ promoteTyVarTcS tclvl tv
| otherwise
= return ()
--- | If the tyvar is a levity var, set it to Lifted. Returns whether or
+-- | If the tyvar is a RuntimeRep var, set it to PtrRepLifted. Returns whether or
-- not this happened.
defaultTyVar :: TcTyVar -> TcM ()
-- Precondition: MetaTyVars only
-- See Note [DefaultTyVar]
defaultTyVar the_tv
- | isLevityVar the_tv
- = do { traceTc "defaultTyVar levity" (ppr the_tv)
- ; writeMetaTyVar the_tv liftedDataConTy }
+ | isRuntimeRepVar the_tv
+ = do { traceTc "defaultTyVar RuntimeRep" (ppr the_tv)
+ ; writeMetaTyVar the_tv ptrRepLiftedTy }
| otherwise = return () -- The common case
-- | Like 'defaultTyVar', but in the TcS monad.
defaultTyVarTcS :: TcTyVar -> TcS Bool
defaultTyVarTcS the_tv
- | isLevityVar the_tv
- = do { traceTcS "defaultTyVarTcS levity" (ppr the_tv)
- ; unifyTyVar the_tv liftedDataConTy
+ | isRuntimeRepVar the_tv
+ = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)
+ ; unifyTyVar the_tv ptrRepLiftedTy
; return True }
| otherwise
= return False -- the common case
@@ -1591,13 +1591,13 @@ There are two caveats:
Note [DefaultTyVar]
~~~~~~~~~~~~~~~~~~~
defaultTyVar is used on any un-instantiated meta type variables to
-default any levity variables to Lifted. This is important
+default any RuntimeRep variables to PtrRepLifted. This is important
to ensure that instance declarations match. For example consider
instance Show (a->b)
foo x = show (\_ -> True)
-Then we'll get a constraint (Show (p ->q)) where p has kind ArgKind,
+Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r),
and that won't match the typeKind (*) in the instance decl. See tests
tc217 and tc175.
@@ -1607,7 +1607,7 @@ hand. However we aren't ready to default them fully to () or
whatever, because the type-class defaulting rules have yet to run.
An alternate implementation would be to emit a derived constraint setting
-the levity variable to Lifted, but this seems unnecessarily indirect.
+the RuntimeRep variable to PtrRepLifted, but this seems unnecessarily indirect.
Note [Promote _and_ default when inferring]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 921da07d2d..ac2ad01864 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -1309,14 +1309,9 @@ reifyTyCon tc
| isTypeFamilyTyCon tc
= do { let tvs = tyConTyVars tc
- kind = tyConKind tc
+ res_kind = tyConResKind tc
resVar = famTcResVar tc
- -- we need the *result kind* (see #8884)
- (kvs, mono_kind) = splitForAllTys kind
- -- tyConArity includes *kind* params
- (_, res_kind) = splitFunTysN (tyConArity tc - length kvs)
- mono_kind
; kind' <- reifyKind res_kind
; let (resultSig, injectivity) =
case resVar of
@@ -1351,13 +1346,8 @@ reifyTyCon tc
| isDataFamilyTyCon tc
= do { let tvs = tyConTyVars tc
- kind = tyConKind tc
+ res_kind = tyConResKind tc
- -- we need the *result kind* (see #8884)
- (kvs, mono_kind) = splitForAllTys kind
- -- tyConArity includes *kind* params
- (_, res_kind) = splitFunTysN (tyConArity tc - length kvs)
- mono_kind
; kind' <- fmap Just (reifyKind res_kind)
; tvs' <- reifyTyVars tvs (Just tc)
@@ -1732,8 +1722,9 @@ reify_tc_app tc tys
= do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)
; maybe_sig_t (mkThAppTs r_tc tys') }
where
- arity = tyConArity tc
- tc_kind = tyConKind tc
+ arity = tyConArity tc
+ tc_binders = tyConBinders tc
+ tc_res_kind = tyConResKind tc
r_tc | isTupleTyCon tc = if isPromotedDataCon tc
then TH.PromotedTupleT arity
@@ -1756,18 +1747,15 @@ reify_tc_app tc tys
= return th_type
needs_kind_sig
- | Just result_ki <- peel_off_n_args tc_kind (length tys)
- = not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType result_ki
- | otherwise
+ | GT <- compareLength tys tc_binders
+ , tcIsTyVarTy tc_res_kind
= True
-
- peel_off_n_args :: Kind -> Arity -> Maybe Kind
- peel_off_n_args k 0 = Just k
- peel_off_n_args k n
- | Just (_, res_k) <- splitPiTy_maybe k
- = peel_off_n_args res_k (n-1)
| otherwise
- = Nothing
+ = not $
+ isEmptyVarSet $
+ filterVarSet isTyVar $
+ tyCoVarsOfType $
+ mkForAllTys (dropList tys tc_binders) tc_res_kind
reifyPred :: TyCoRep.PredType -> TcM TH.Pred
reifyPred ty
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index e68efd09f9..6fee0124a3 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -126,8 +126,8 @@ tcTyClGroup tyclds
= do { -- Step 1: kind-check this group and returns the final
-- (possibly-polymorphic) kind of each TyCon and Class
-- See Note [Kind checking for type and class decls]
- names_w_poly_kinds <- kcTyClGroup tyclds
- ; traceTc "tcTyAndCl generalized kinds" (ppr names_w_poly_kinds)
+ tc_tycons <- kcTyClGroup tyclds
+ ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))
-- Step 2: type-check all groups together, returning
-- the final TyCons and Classes
@@ -143,13 +143,12 @@ tcTyClGroup tyclds
-- NB: if the decls mention any ill-staged data cons
-- (see Note [Recusion and promoting data constructors])
-- we will have failed already in kcTyClGroup, so no worries here
- ; tcExtendRecEnv (zipRecTyClss names_w_poly_kinds rec_tyclss) $
+ ; tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $
-- Also extend the local type envt with bindings giving
-- the (polymorphic) kind of each knot-tied TyCon or Class
-- See Note [Type checking recursive type and class declarations]
- tcExtendKindEnv2 [ mkTcTyConPair name kind m_arity
- | (name, kind, m_arity) <- names_w_poly_kinds ] $
+ tcExtendKindEnv2 (map mkTcTyConPair tc_tycons) $
-- Kind and type check declarations for this group
mapM (tcTyClDecl rec_flags) decls }
@@ -169,8 +168,12 @@ tcTyClGroup tyclds
-- they may be mentioned in interface files
; tcExtendTyConEnv tyclss $
tcAddImplicits tyclss }
+ where
+ ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma
+ , ppr (tyConBinders tc) <> comma
+ , ppr (tyConResKind tc) ])
-zipRecTyClss :: [(Name, Kind, Maybe Arity)]
+zipRecTyClss :: [TcTyCon]
-> [TyCon] -- Knot-tied
-> [(Name,TyThing)]
-- Build a name-TyThing mapping for the TyCons bound by decls
@@ -178,8 +181,8 @@ zipRecTyClss :: [(Name, Kind, Maybe Arity)]
-- The TyThings in the result list must have a visible ATyCon,
-- because typechecking types (in, say, tcTyClDecl) looks at
-- this outer constructor
-zipRecTyClss kind_pairs rec_tycons
- = [ (name, ATyCon (get name)) | (name, _kind, _m_arity) <- kind_pairs ]
+zipRecTyClss tc_tycons rec_tycons
+ = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ]
where
rec_tc_env :: NameEnv TyCon
rec_tc_env = foldr add_tc emptyNameEnv rec_tycons
@@ -260,7 +263,7 @@ See also Note [Kind checking recursive type and class declarations]
-}
-kcTyClGroup :: TyClGroup Name -> TcM [(Name,Kind,Maybe Arity)]
+kcTyClGroup :: TyClGroup Name -> TcM [TcTyCon]
-- Kind check this group, kind generalize, and return the resulting local env
-- This bindds the TyCons and Classes of the group, but not the DataCons
-- See Note [Kind checking for type and class decls]
@@ -303,24 +306,29 @@ kcTyClGroup (TyClGroup { group_tyclds = decls })
; return res }
where
- generalise :: TcTypeEnv -> Name -> TcM (Name, Kind, Maybe Arity)
+ generalise :: TcTypeEnv -> Name -> TcM TcTyCon
-- For polymorphic things this is a no-op
generalise kind_env name
- = do { let (kc_kind, kc_unsat) = case lookupNameEnv kind_env name of
- Just (ATcTyCon tc) -> ( tyConKind tc
- , if mightBeUnsaturatedTyCon tc
- then Nothing
- else Just $ tyConArity tc )
- _ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env)
- ; kvs <- kindGeneralize kc_kind
- ; kc_kind' <- zonkTcTypeToType emptyZonkEnv kc_kind
+ = do { let tc = case lookupNameEnv kind_env name of
+ Just (ATcTyCon tc) -> tc
+ _ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env)
+ kc_binders = tyConBinders tc
+ kc_res_kind = tyConResKind tc
+ ; kvs <- kindGeneralize (mkForAllTys kc_binders kc_res_kind)
+ ; (kc_binders', kc_res_kind') <- zonkTcKindToKind kc_binders kc_res_kind
-- Make sure kc_kind' has the final, zonked kind variables
- ; traceTc "Generalise kind" (vcat [ ppr name, ppr kc_kind, ppr kvs, ppr kc_kind' ])
- ; return (name, mkInvForAllTys kvs kc_kind', kc_unsat) }
+ ; traceTc "Generalise kind" $
+ vcat [ ppr name, ppr kc_binders, ppr kc_res_kind
+ , ppr kvs, ppr kc_binders', ppr kc_res_kind' ]
+
+ ; return (mkTcTyCon name
+ (map (mkNamedBinder Invisible) kvs ++ kc_binders')
+ kc_res_kind'
+ (mightBeUnsaturatedTyCon tc)) }
generaliseTCD :: TcTypeEnv
- -> LTyClDecl Name -> TcM [(Name, Kind, Maybe Arity)]
+ -> LTyClDecl Name -> TcM [TcTyCon]
generaliseTCD kind_env (L _ decl)
| ClassDecl { tcdLName = (L _ name), tcdATs = ats } <- decl
= do { first <- generalise kind_env name
@@ -336,19 +344,15 @@ kcTyClGroup (TyClGroup { group_tyclds = decls })
; return [res] }
generaliseFamDecl :: TcTypeEnv
- -> FamilyDecl Name -> TcM (Name, Kind, Maybe Arity)
+ -> FamilyDecl Name -> TcM TcTyCon
generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name })
= generalise kind_env name
-mkTcTyConPair :: Name -> TcKind
- -> Maybe Arity -- ^ Nothing <=> tycon can be unsaturated
- -> (Name, TcTyThing)
+mkTcTyConPair :: TcTyCon -> (Name, TcTyThing)
-- Makes a binding to put in the local envt, binding
--- a name to a TcTyCon with the specified kind
-mkTcTyConPair name kind Nothing
- = (name, ATcTyCon (mkTcTyCon name kind True 0))
-mkTcTyConPair name kind (Just arity)
- = (name, ATcTyCon (mkTcTyCon name kind False arity))
+-- a name to a TcTyCon
+mkTcTyConPair tc
+ = (getName tc, ATcTyCon tc)
mk_thing_env :: [LTyClDecl Name] -> [(Name, TcTyThing)]
mk_thing_env [] = []
@@ -388,26 +392,28 @@ getInitialKind :: TyClDecl Name
-- No family instances are passed to getInitialKinds
getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats })
- = do { (cl_kind, inner_prs) <-
+ = do { (cl_binders, cl_kind, inner_prs) <-
kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ \_ _ ->
do { inner_prs <- getFamDeclInitialKinds ats
; return (constraintKind, inner_prs) }
- ; cl_kind <- zonkTcType cl_kind
- ; let main_pr = mkTcTyConPair name cl_kind Nothing
+ ; cl_binders <- mapM zonkTcTyBinder cl_binders
+ ; cl_kind <- zonkTcType cl_kind
+ ; let main_pr = mkTcTyConPair (mkTcTyCon name cl_binders cl_kind True)
; return (main_pr : inner_prs) }
getInitialKind decl@(DataDecl { tcdLName = L _ name
, tcdTyVars = ktvs
, tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
, dd_cons = cons } })
- = do { (decl_kind, _) <-
+ = do { (decl_binders, decl_kind, _) <-
kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ \_ _ ->
do { res_k <- case m_sig of
Just ksig -> tcLHsKind ksig
Nothing -> return liftedTypeKind
; return (res_k, ()) }
- ; decl_kind <- zonkTcType decl_kind
- ; let main_pr = mkTcTyConPair name decl_kind Nothing
+ ; decl_binders <- mapM zonkTcTyBinder decl_binders
+ ; decl_kind <- zonkTcType decl_kind
+ ; let main_pr = mkTcTyConPair (mkTcTyCon name decl_binders decl_kind True)
inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
| L _ con' <- cons, con <- getConNames con' ]
; return (main_pr : inner_prs) }
@@ -431,7 +437,7 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name
, fdTyVars = ktvs
, fdResultSig = L _ resultSig
, fdInfo = info })
- = do { (fam_kind, _) <-
+ = do { (fam_binders, fam_kind, _) <-
kcHsTyVarBndrs (famDeclHasCusk decl) ktvs $ \_ _ ->
do { res_k <- case resultSig of
KindSig ki -> tcLHsKind ki
@@ -442,42 +448,43 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name
-- by default
| otherwise -> newMetaKindVar
; return (res_k, ()) }
- ; fam_kind <- zonkTcType fam_kind
- ; return [ mkTcTyConPair name fam_kind m_arity ] }
+ ; fam_binders <- mapM zonkTcTyBinder fam_binders
+ ; fam_kind <- zonkTcType fam_kind
+ ; return [ mkTcTyConPair (mkTcTyCon name fam_binders fam_kind unsat) ] }
where
- m_arity = case info of
- DataFamily -> Nothing
- OpenTypeFamily -> Just (length $ hsQTvExplicit ktvs)
- ClosedTypeFamily _ -> Just (length $ hsQTvExplicit ktvs)
+ unsat = case info of
+ DataFamily -> True
+ OpenTypeFamily -> False
+ ClosedTypeFamily _ -> False
----------------
kcSynDecls :: [SCC (LTyClDecl Name)]
-> TcM TcLclEnv -- Kind bindings
kcSynDecls [] = getLclEnv
kcSynDecls (group : groups)
- = do { (n,k,arity) <- kcSynDecl1 group
- ; tcExtendKindEnv2 [ mkTcTyConPair n k (Just arity) ] $
+ = do { tc <- kcSynDecl1 group
+ ; tcExtendKindEnv2 [ mkTcTyConPair tc ] $
kcSynDecls groups }
kcSynDecl1 :: SCC (LTyClDecl Name)
- -> TcM (Name,TcKind,Arity) -- Kind bindings
+ -> TcM TcTyCon -- Kind bindings
kcSynDecl1 (AcyclicSCC (L _ decl)) = kcSynDecl decl
kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM }
-- Fail here to avoid error cascade
-- of out-of-scope tycons
-kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind, Arity)
+kcSynDecl :: TyClDecl Name -> TcM TcTyCon
kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name
, tcdRhs = rhs })
-- Returns a possibly-unzonked kind
= tcAddDeclCtxt decl $
- do { (syn_kind, _) <-
+ do { (syn_binders, syn_kind, _) <-
kcHsTyVarBndrs (hsDeclHasCusk decl) hs_tvs $ \_ _ ->
do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs))
; (_, rhs_kind) <- tcLHsType rhs
; traceTc "kcd2" (ppr name)
; return (rhs_kind, ()) }
- ; return (name, syn_kind, length $ hsQTvExplicit hs_tvs) }
+ ; return (mkTcTyCon name syn_binders syn_kind False) }
kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl)
------------------------------------------------------------------------
@@ -525,10 +532,11 @@ kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name
-- do anything here
= case fd_info of
ClosedTypeFamily (Just eqns) ->
- do { tc_kind <- kcLookupKind fam_tc_name
+ do { (tc_binders, tc_res_kind) <- kcLookupKind fam_tc_name
; let fam_tc_shape = ( fam_tc_name
, length $ hsQTvExplicit hs_tvs
- , tc_kind )
+ , tc_binders
+ , tc_res_kind )
; mapM_ (kcTyFamInstEqn fam_tc_shape) eqns }
_ -> return ()
@@ -676,15 +684,15 @@ tcTyClDecl1 parent _rec_info (FamDecl { tcdFam = fd })
tcTyClDecl1 _parent rec_info
(SynDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdRhs = rhs })
= ASSERT( isNothing _parent )
- tcTyClTyVars tc_name tvs $ \ kvs' tvs' full_kind res_kind ->
- tcTySynRhs rec_info tc_name (kvs' ++ tvs') full_kind res_kind rhs
+ tcTyClTyVars tc_name tvs $ \ kvs' tvs' binders res_kind ->
+ tcTySynRhs rec_info tc_name (kvs' ++ tvs') binders res_kind rhs
-- "data/newtype" declaration
tcTyClDecl1 _parent rec_info
(DataDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdDataDefn = defn })
= ASSERT( isNothing _parent )
- tcTyClTyVars tc_name tvs $ \ kvs' tvs' tycon_kind res_kind ->
- tcDataDefn rec_info tc_name (kvs' ++ tvs') tycon_kind res_kind defn
+ tcTyClTyVars tc_name tvs $ \ kvs' tvs' tycon_binders res_kind ->
+ tcDataDefn rec_info tc_name (kvs' ++ tvs') tycon_binders res_kind defn
tcTyClDecl1 _parent rec_info
(ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs
@@ -693,13 +701,13 @@ tcTyClDecl1 _parent rec_info
, tcdATs = ats, tcdATDefs = at_defs })
= ASSERT( isNothing _parent )
do { clas <- fixM $ \ clas ->
- tcTyClTyVars class_name tvs $ \ kvs' tvs' full_kind res_kind ->
+ tcTyClTyVars class_name tvs $ \ kvs' tvs' binders res_kind ->
do { MASSERT( isConstraintKind res_kind )
-- This little knot is just so we can get
-- hold of the name of the class TyCon, which we
-- need to look up its recursiveness
; traceTc "tcClassDecl 1" (ppr class_name $$ ppr kvs' $$
- ppr tvs' $$ ppr full_kind)
+ ppr tvs' $$ ppr binders)
; let tycon_name = tyConName (classTyCon clas)
tc_isrec = rti_is_rec rec_info tycon_name
roles = rti_roles rec_info tycon_name
@@ -712,7 +720,7 @@ tcTyClDecl1 _parent rec_info
; at_stuff <- tcClassATs class_name clas ats at_defs
; mindef <- tcClassMinimalDef class_name sigs sig_stuff
; clas <- buildClass
- class_name (kvs' ++ tvs') roles ctxt' full_kind
+ class_name (kvs' ++ tvs') roles ctxt' binders
fds' at_stuff
sig_stuff mindef tc_isrec
; traceTc "tcClassDecl" (ppr fundeps $$ ppr (kvs' ++ tvs') $$
@@ -730,25 +738,26 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na
, fdTyVars = tvs, fdResultSig = L _ sig
, fdInjectivityAnn = inj })
| DataFamily <- fam_info
- = tcTyClTyVars tc_name tvs $ \ kvs' tvs' tycon_kind res_kind -> do
+ = tcTyClTyVars tc_name tvs $ \ kvs' tvs' binders res_kind -> do
{ traceTc "data family:" (ppr tc_name)
; checkFamFlag tc_name
- ; extra_tvs <- tcDataKindSig res_kind
+ ; (extra_tvs, extra_binders, real_res_kind) <- tcDataKindSig res_kind
; tc_rep_name <- newTyConRepName tc_name
; let final_tvs = (kvs' ++ tvs') `chkAppend` extra_tvs -- we may not need these
- tycon = mkFamilyTyCon tc_name tycon_kind final_tvs
+ tycon = mkFamilyTyCon tc_name (binders `chkAppend` extra_binders)
+ real_res_kind final_tvs
(resultVariableName sig)
(DataFamilyTyCon tc_rep_name)
parent NotInjective
; return tycon }
| OpenTypeFamily <- fam_info
- = tcTyClTyVars tc_name tvs $ \ kvs' tvs' full_kind _res_kind -> do
+ = tcTyClTyVars tc_name tvs $ \ kvs' tvs' binders res_kind -> do
{ traceTc "open type family:" (ppr tc_name)
; checkFamFlag tc_name
; let all_tvs = kvs' ++ tvs'
; inj' <- tcInjectivity all_tvs inj
- ; let tycon = mkFamilyTyCon tc_name full_kind all_tvs
+ ; let tycon = mkFamilyTyCon tc_name binders res_kind all_tvs
(resultVariableName sig) OpenSynFamilyTyCon
parent inj'
; return tycon }
@@ -759,11 +768,12 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na
do { traceTc "Closed type family:" (ppr tc_name)
-- the variables in the header scope only over the injectivity
-- declaration but this is not involved here
- ; (tvs', inj', kind) <- tcTyClTyVars tc_name tvs
- $ \ kvs' tvs' full_kind _res_kind ->
- do { let all_tvs = kvs' ++ tvs'
- ; inj' <- tcInjectivity all_tvs inj
- ; return (all_tvs, inj', full_kind) }
+ ; (tvs', inj', binders, res_kind)
+ <- tcTyClTyVars tc_name tvs
+ $ \ kvs' tvs' binders res_kind ->
+ do { let all_tvs = kvs' ++ tvs'
+ ; inj' <- tcInjectivity all_tvs inj
+ ; return (all_tvs, inj', binders, res_kind) }
; checkFamFlag tc_name -- make sure we have -XTypeFamilies
@@ -771,14 +781,14 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na
-- but eqns might be empty in the Just case as well
; case mb_eqns of
Nothing ->
- return $ mkFamilyTyCon tc_name kind tvs'
+ return $ mkFamilyTyCon tc_name binders res_kind tvs'
(resultVariableName sig)
AbstractClosedSynFamilyTyCon parent
inj'
Just eqns -> do {
-- Process the equations, creating CoAxBranches
- ; let fam_tc_shape = (tc_name, length $ hsQTvExplicit tvs, kind)
+ ; let fam_tc_shape = (tc_name, length $ hsQTvExplicit tvs, binders, res_kind)
; branches <- mapM (tcTyFamInstEqn fam_tc_shape Nothing) eqns
-- Do not attempt to drop equations dominated by earlier
@@ -800,7 +810,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na
| null eqns = Nothing -- mkBranchedCoAxiom fails on empty list
| otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches)
- fam_tc = mkFamilyTyCon tc_name kind tvs' (resultVariableName sig)
+ fam_tc = mkFamilyTyCon tc_name binders res_kind tvs' (resultVariableName sig)
(ClosedSynFamilyTyCon mb_co_ax) parent inj'
-- We check for instance validity later, when doing validity
@@ -856,27 +866,27 @@ tcInjectivity tvs (Just (L loc (InjectivityAnn _ lInjNames)))
tcTySynRhs :: RecTyInfo
-> Name
- -> [TyVar] -> Kind -> Kind
+ -> [TyVar] -> [TyBinder] -> Kind
-> LHsType Name -> TcM TyCon
-tcTySynRhs rec_info tc_name tvs full_kind res_kind hs_ty
+tcTySynRhs rec_info tc_name tvs binders res_kind hs_ty
= do { env <- getLclEnv
; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))
; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
; let roles = rti_roles rec_info tc_name
- tycon = mkSynonymTyCon tc_name full_kind tvs roles rhs_ty
+ tycon = mkSynonymTyCon tc_name binders res_kind tvs roles rhs_ty
; return tycon }
tcDataDefn :: RecTyInfo -> Name
- -> [TyVar] -> Kind -> Kind
+ -> [TyVar] -> [TyBinder] -> Kind
-> HsDataDefn Name -> TcM TyCon
-- NB: not used for newtype/data instances (whether associated or not)
tcDataDefn rec_info -- Knot-tied; don't look at this eagerly
- tc_name tvs tycon_kind res_kind
+ tc_name tvs tycon_binders res_kind
(HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = ctxt, dd_kindSig = mb_ksig
, dd_cons = cons })
- = do { extra_tvs <- tcDataKindSig res_kind
+ = do { (extra_tvs, extra_bndrs, real_res_kind) <- tcDataKindSig res_kind
; let final_tvs = tvs `chkAppend` extra_tvs
roles = rti_roles rec_info tc_name
@@ -897,7 +907,8 @@ tcDataDefn rec_info -- Knot-tied; don't look at this eagerly
; data_cons <- tcConDecls new_or_data tycon (final_tvs, res_ty) cons
; tc_rhs <- mk_tc_rhs is_boot tycon data_cons
; tc_rep_nm <- newTyConRepName tc_name
- ; return (mkAlgTyCon tc_name tycon_kind final_tvs roles
+ ; return (mkAlgTyCon tc_name (tycon_binders `chkAppend` extra_bndrs)
+ real_res_kind final_tvs roles
(fmap unLoc cType)
stupid_theta tc_rhs
(VanillaAlgTyCon tc_rep_nm)
@@ -987,7 +998,7 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name
setSrcSpan loc $
tcAddFamInstCtxt (text "default type instance") tc_name $
do { traceTc "tcDefaultAssocDecl" (ppr tc_name)
- ; let shape@(fam_tc_name, fam_arity, _) = famTyConShape fam_tc
+ ; let shape@(fam_tc_name, fam_arity, _, _) = famTyConShape fam_tc
-- Kind of family check
; ASSERT( fam_tc_name == tc_name )
@@ -1053,7 +1064,7 @@ kcTyFamInstEqn fam_tc_shape
tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInfo -> LTyFamInstEqn Name -> TcM CoAxBranch
-- Needs to be here, not in TcInstDcls, because closed families
-- (typechecked here) have TyFamInstEqns
-tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_) mb_clsinfo
+tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) mb_clsinfo
(L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name
, tfe_pats = pats
, tfe_rhs = hs_ty }))
@@ -1130,13 +1141,15 @@ two bad things could happen:
-}
-----------------
-type FamTyConShape = (Name, Arity, Kind) -- See Note [Type-checking type patterns]
+type FamTyConShape = (Name, Arity, [TyBinder], Kind)
+ -- See Note [Type-checking type patterns]
famTyConShape :: TyCon -> FamTyConShape
famTyConShape fam_tc
= ( tyConName fam_tc
, length $ filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)
- , tyConKind fam_tc )
+ , tyConBinders fam_tc
+ , tyConResKind fam_tc )
tc_fam_ty_pats :: FamTyConShape
-> Maybe ClsInfo
@@ -1155,21 +1168,24 @@ tc_fam_ty_pats :: FamTyConShape
-- In that case, the type variable 'a' will *already be in scope*
-- (and, if C is poly-kinded, so will its kind parameter).
-tc_fam_ty_pats (name, _, kind) mb_clsinfo
+tc_fam_ty_pats (name, _, binders, res_kind) mb_clsinfo
(HsIB { hsib_body = arg_pats, hsib_vars = tv_names })
kind_checker
= do { -- Kind-check and quantify
-- See Note [Quantifying over family patterns]
- (_, (res_kind, typats)) <- tcImplicitTKBndrs tv_names $
- do { (res_kind, args, leftovers, n)
- <- tcInferArgs name kind (snd <$> mb_clsinfo) arg_pats
+ (_, (insted_res_kind, typats)) <- tcImplicitTKBndrs tv_names $
+ do { (insting_subst, _leftover_binders, args, leftovers, n)
+ <- tcInferArgs name binders (snd <$> mb_clsinfo) arg_pats
; case leftovers of
hs_ty:_ -> addErrTc $ too_many_args hs_ty n
_ -> return ()
- ; kind_checker res_kind
- ; return ((res_kind, args), emptyVarSet) }
+ -- don't worry about leftover_binders; TcValidity catches them
+
+ ; let insted_res_kind = substTyUnchecked insting_subst res_kind
+ ; kind_checker insted_res_kind
+ ; return ((insted_res_kind, args), emptyVarSet) }
- ; return (typats, res_kind) }
+ ; return (typats, insted_res_kind) }
where
too_many_args hs_ty n
= hang (text "Too many parameters to" <+> ppr name <> colon)
@@ -1186,7 +1202,7 @@ tcFamTyPats :: FamTyConShape
-> [TcType] -- Kind and type arguments
-> Kind -> TcM a) -- NB: You can use solveEqualities here.
-> TcM a
-tcFamTyPats fam_shape@(name,_,_) mb_clsinfo pats kind_checker thing_inside
+tcFamTyPats fam_shape@(name,_,_,_) mb_clsinfo pats kind_checker thing_inside
= do { (typats, res_kind)
<- solveEqualities $ -- See Note [Constraints in patterns]
tc_fam_ty_pats fam_shape mb_clsinfo pats kind_checker
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index 00b3a0f07b..972cbae749 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -22,7 +22,7 @@ module TcType (
-- Types
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet,
- TcKind, TcCoVar, TcTyCoVar, TcTyBinder,
+ TcKind, TcCoVar, TcTyCoVar, TcTyBinder, TcTyCon,
ExpType(..), ExpSigmaType, ExpRhoType, mkCheckExpType,
@@ -121,7 +121,7 @@ module TcType (
--------------------------------
-- Rexported from Kind
Kind, typeKind,
- unliftedTypeKind, liftedTypeKind,
+ liftedTypeKind,
constraintKind,
isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues,
@@ -140,7 +140,7 @@ module TcType (
mkClassPred,
isDictLikeTy,
tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,
- isLevityVar, isLevityPolymorphic, isLevityPolymorphic_maybe,
+ isRuntimeRepVar, isRuntimeRepPolymorphic,
isVisibleBinder, isInvisibleBinder,
-- Type substitutions
@@ -269,6 +269,7 @@ type TcTyCoVar = Var -- Either a TcTyVar or a CoVar
-- a cannot occur inside a MutTyVar in T; that is,
-- T is "flattened" before quantifying over a
type TcTyBinder = TyBinder
+type TcTyCon = TyCon -- these can be the TcTyCon constructor
-- These types do not have boxy type variables in them
type TcPredType = PredType
@@ -1375,9 +1376,8 @@ tc_eq_type view_fun orig_ty1 orig_ty2 = go Visible orig_env orig_ty1 orig_ty2
-- the repeat Visible is necessary because tycons can legitimately
-- be oversaturated
where
- k = tyConKind tc
- (bndrs, _) = splitPiTys k
- viss = map binderVisibility bndrs
+ bndrs = tyConBinders tc
+ viss = map binderVisibility bndrs
check :: VisibilityFlag -> Bool -> Maybe VisibilityFlag
check _ True = Nothing
diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs
index e7fb85fdbe..e6a6c7ed70 100644
--- a/compiler/typecheck/TcTypeNats.hs
+++ b/compiler/typecheck/TcTypeNats.hs
@@ -100,7 +100,8 @@ typeNatExpTyCon = mkTypeNatFunTyCon2 name
typeNatLeqTyCon :: TyCon
typeNatLeqTyCon =
mkFamilyTyCon name
- (mkFunTys [ typeNatKind, typeNatKind ] boolTy)
+ (map mkAnonBinder [ typeNatKind, typeNatKind ])
+ boolTy
(mkTemplateTyVars [ typeNatKind, typeNatKind ])
Nothing
(BuiltInSynFamTyCon ops)
@@ -119,7 +120,8 @@ typeNatLeqTyCon =
typeNatCmpTyCon :: TyCon
typeNatCmpTyCon =
mkFamilyTyCon name
- (mkFunTys [ typeNatKind, typeNatKind ] orderingKind)
+ (map mkAnonBinder [ typeNatKind, typeNatKind ])
+ orderingKind
(mkTemplateTyVars [ typeNatKind, typeNatKind ])
Nothing
(BuiltInSynFamTyCon ops)
@@ -138,7 +140,8 @@ typeNatCmpTyCon =
typeSymbolCmpTyCon :: TyCon
typeSymbolCmpTyCon =
mkFamilyTyCon name
- (mkFunTys [ typeSymbolKind, typeSymbolKind ] orderingKind)
+ (map mkAnonBinder [ typeSymbolKind, typeSymbolKind ])
+ orderingKind
(mkTemplateTyVars [ typeSymbolKind, typeSymbolKind ])
Nothing
(BuiltInSynFamTyCon ops)
@@ -162,7 +165,8 @@ typeSymbolCmpTyCon =
mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon
mkTypeNatFunTyCon2 op tcb =
mkFamilyTyCon op
- (mkFunTys [ typeNatKind, typeNatKind ] typeNatKind)
+ (map mkAnonBinder [ typeNatKind, typeNatKind ])
+ typeNatKind
(mkTemplateTyVars [ typeNatKind, typeNatKind ])
Nothing
(BuiltInSynFamTyCon tcb)
diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs
index e25ff2191c..77651c8568 100644
--- a/compiler/typecheck/TcUnify.hs
+++ b/compiler/typecheck/TcUnify.hs
@@ -381,16 +381,9 @@ matchExpectedTyConApp tc orig_ty
-- because that'll make types that are utterly ill-kinded.
-- This happened in Trac #7368
defer
- = ASSERT2( classifiesTypeWithValues res_kind, ppr tc )
- do { (k_subst, kvs') <- newMetaTyVars kvs
- ; let arg_kinds' = substTys k_subst arg_kinds
- kappa_tys = mkTyVarTys kvs'
- ; tau_tys <- mapM newFlexiTyVarTy arg_kinds'
- ; co <- unifyType noThing (mkTyConApp tc (kappa_tys ++ tau_tys)) orig_ty
- ; return (co, kappa_tys ++ tau_tys) }
-
- (bndrs, res_kind) = splitPiTys (tyConKind tc)
- (kvs, arg_kinds) = partitionBinders bndrs
+ = do { (_subst, args) <- tcInstBinders (tyConBinders tc)
+ ; co <- unifyType noThing (mkTyConApp tc args) orig_ty
+ ; return (co, args) }
----------------------
matchExpectedAppTy :: TcRhoType -- orig_ty
@@ -1181,13 +1174,13 @@ uType origin t_or_k orig_ty1 orig_ty2
do { cos <- zipWith3M (uType origin) t_or_ks tys1 tys2
; return $ mkTyConAppCo Nominal tc1 cos }
where
- (bndrs, _) = splitPiTys (tyConKind tc1)
+ bndrs = tyConBinders tc1
t_or_ks = case t_or_k of
KindLevel -> repeat KindLevel
TypeLevel -> map (\bndr -> if isNamedBinder bndr
then KindLevel
- else TypeLevel)
- bndrs
+ else TypeLevel) bndrs ++
+ repeat TypeLevel
go (LitTy m) ty@(LitTy n)
| m == n
diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 56cb348669..319c15dd77 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -945,7 +945,7 @@ tyConArityErr tc tks
-- tc_type_arity = number of *type* args expected
-- tc_type_args = number of *type* args encountered
- tc_type_arity = count isVisibleBinder $ fst $ splitPiTys (tyConKind tc)
+ tc_type_arity = count isVisibleBinder $ tyConBinders tc
tc_type_args = length vis_tks
arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc
@@ -1583,7 +1583,7 @@ checkValidFamPats mb_clsinfo fam_tc tvs cvs ty_pats
; checkConsistentFamInst mb_clsinfo fam_tc tvs ty_pats }
where
fam_arity = tyConArity fam_tc
- fam_bndrs = take fam_arity $ fst $ splitPiTys (tyConKind fam_tc)
+ fam_bndrs = tyConBinders fam_tc
checkValidTypePat :: Type -> TcM ()
diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs
index 1ce0bbf0ed..ac7fc586aa 100644
--- a/compiler/types/Kind.hs
+++ b/compiler/types/Kind.hs
@@ -14,7 +14,7 @@ module Kind (
classifiesTypeWithValues,
isStarKind, isStarKindSynonymTyCon,
- isLevityPolymorphic, isLevityPolymorphic_maybe
+ isRuntimeRepPolymorphic
) where
#include "HsVersions.h"
@@ -23,9 +23,8 @@ import {-# SOURCE #-} Type ( typeKind, coreViewOneStarKind )
import TyCoRep
import TyCon
-import Var
+import VarSet ( isEmptyVarSet )
import PrelNames
-import Data.Maybe
import Util ( (<&&>) )
{-
@@ -78,19 +77,11 @@ returnsTyCon _ _ = False
returnsConstraintKind :: Kind -> Bool
returnsConstraintKind = returnsTyCon constraintKindTyConKey
--- | Tests whether the given type looks like "TYPE v", where v is a variable.
-isLevityPolymorphic :: Kind -> Bool
-isLevityPolymorphic = isJust . isLevityPolymorphic_maybe
-
--- | Retrieves a levity variable in the given kind, if the kind is of the
--- form "TYPE v".
-isLevityPolymorphic_maybe :: Kind -> Maybe TyVar
-isLevityPolymorphic_maybe k
- | Just k' <- coreViewOneStarKind k = isLevityPolymorphic_maybe k'
-isLevityPolymorphic_maybe (TyConApp tc [TyVarTy v])
- | tc `hasKey` tYPETyConKey
- = Just v
-isLevityPolymorphic_maybe _ = Nothing
+-- | Tests whether the given type (which should look like "TYPE ...") has any
+-- free variables
+isRuntimeRepPolymorphic :: Kind -> Bool
+isRuntimeRepPolymorphic k
+ = not $ isEmptyVarSet $ tyCoVarsOfType k
--------------------------------------------
-- Kinding for arrow (->)
@@ -98,7 +89,7 @@ isLevityPolymorphic_maybe _ = Nothing
-- arg -> res
okArrowArgKind, okArrowResultKind :: Kind -> Bool
-okArrowArgKind = classifiesTypeWithValues <&&> (not . isLevityPolymorphic)
+okArrowArgKind = classifiesTypeWithValues <&&> (not . isRuntimeRepPolymorphic)
okArrowResultKind = classifiesTypeWithValues
-----------------------------------------
@@ -119,8 +110,9 @@ classifiesTypeWithValues _ = False
-- | Is this kind equivalent to *?
isStarKind :: Kind -> Bool
isStarKind k | Just k' <- coreViewOneStarKind k = isStarKind k'
-isStarKind (TyConApp tc [TyConApp l []]) = tc `hasKey` tYPETyConKey
- && l `hasKey` liftedDataConKey
+isStarKind (TyConApp tc [TyConApp ptr_rep []])
+ = tc `hasKey` tYPETyConKey
+ && ptr_rep `hasKey` ptrRepLiftedDataConKey
isStarKind _ = False
-- See Note [Kind Constraint and kind *]
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index ad583eab3f..56247300b9 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -37,10 +37,10 @@ module TyCoRep (
-- Functions over types
mkTyConTy, mkTyVarTy, mkTyVarTys,
- mkFunTy, mkFunTys,
+ mkFunTy, mkFunTys, mkForAllTys,
isLiftedTypeKind, isUnliftedTypeKind,
- isCoercionType, isLevityTy, isLevityVar,
- isLevityKindedTy, dropLevityArgs,
+ isCoercionType, isRuntimeRepTy, isRuntimeRepVar,
+ isRuntimeRepKindedTy, dropRuntimeRepArgs,
sameVis,
-- Functions over binders
@@ -465,6 +465,10 @@ mkFunTy arg res = ForAllTy (Anon arg) res
mkFunTys :: [Type] -> Type -> Type
mkFunTys tys ty = foldr mkFunTy ty tys
+-- | Wraps foralls over the type using the provided 'TyVar's from left to right
+mkForAllTys :: [TyBinder] -> Type -> Type
+mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
+
-- | Does this type classify a core Coercion?
isCoercionType :: Type -> Bool
isCoercionType (TyConApp tc tys)
@@ -514,39 +518,47 @@ mkTyConTy tycon = TyConApp tycon []
Some basic functions, put here to break loops eg with the pretty printer
-}
+-- | This version considers Constraint to be distinct from *.
isLiftedTypeKind :: Kind -> Bool
isLiftedTypeKind ki | Just ki' <- coreView ki = isLiftedTypeKind ki'
-isLiftedTypeKind (TyConApp tc [TyConApp lev []])
- = tc `hasKey` tYPETyConKey && lev `hasKey` liftedDataConKey
+isLiftedTypeKind (TyConApp tc [TyConApp ptr_rep []])
+ = tc `hasKey` tYPETyConKey
+ && ptr_rep `hasKey` ptrRepLiftedDataConKey
isLiftedTypeKind _ = False
isUnliftedTypeKind :: Kind -> Bool
isUnliftedTypeKind ki | Just ki' <- coreView ki = isUnliftedTypeKind ki'
-isUnliftedTypeKind (TyConApp tc [TyConApp lev []])
- = tc `hasKey` tYPETyConKey && lev `hasKey` unliftedDataConKey
+isUnliftedTypeKind (TyConApp tc [TyConApp ptr_rep []])
+ | tc `hasKey` tYPETyConKey
+ , ptr_rep `hasKey` ptrRepLiftedDataConKey
+ = False
+isUnliftedTypeKind (TyConApp tc [arg])
+ = tc `hasKey` tYPETyConKey && isEmptyVarSet (tyCoVarsOfType arg)
+ -- all other possibilities are unlifted
isUnliftedTypeKind _ = False
--- | Is this the type 'Levity'?
-isLevityTy :: Type -> Bool
-isLevityTy ty | Just ty' <- coreView ty = isLevityTy ty'
-isLevityTy (TyConApp tc []) = tc `hasKey` levityTyConKey
-isLevityTy _ = False
+-- | Is this the type 'RuntimeRep'?
+isRuntimeRepTy :: Type -> Bool
+isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty'
+isRuntimeRepTy (TyConApp tc []) = tc `hasKey` runtimeRepTyConKey
+isRuntimeRepTy _ = False
--- | Is this a type of kind Levity? (e.g. Lifted, Unlifted)
-isLevityKindedTy :: Type -> Bool
-isLevityKindedTy = isLevityTy . typeKind
+-- | Is this a type of kind RuntimeRep? (e.g. PtrRep)
+isRuntimeRepKindedTy :: Type -> Bool
+isRuntimeRepKindedTy = isRuntimeRepTy . typeKind
--- | Is a tyvar of type 'Levity'?
-isLevityVar :: TyVar -> Bool
-isLevityVar = isLevityTy . tyVarKind
+-- | Is a tyvar of type 'RuntimeRep'?
+isRuntimeRepVar :: TyVar -> Bool
+isRuntimeRepVar = isRuntimeRepTy . tyVarKind
--- | Drops prefix of Levity constructors in 'TyConApp's. Useful for e.g.
--- dropping 'Lifted and 'Unlifted arguments of unboxed tuple TyCon applications:
+-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g.
+-- dropping 'PtrRep arguments of unboxed tuple TyCon applications:
--
--- dropLevityArgs ['Lifted, 'Unlifted, String, Int#] == [String, Int#]
+-- dropRuntimeRepArgs [ 'PtrRepLifted, 'PtrRepUnlifted
+-- , String, Int# ] == [String, Int#]
--
-dropLevityArgs :: [Type] -> [Type]
-dropLevityArgs = dropWhile isLevityKindedTy
+dropRuntimeRepArgs :: [Type] -> [Type]
+dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy
{-
%************************************************************************
@@ -2657,11 +2669,14 @@ pprTyTcApp p tc tys
= text "(TypeError ...)" -- Suppress detail unles you _really_ want to see
| tc `hasKey` tYPETyConKey
- , [TyConApp lev_tc []] <- tys
- = if | lev_tc `hasKey` liftedDataConKey ->
- unicodeSyntax (char '★') (char '*')
- | lev_tc `hasKey` unliftedDataConKey -> char '#'
- | otherwise -> ppr_deflt
+ , [TyConApp ptr_rep []] <- tys
+ , ptr_rep `hasKey` ptrRepLiftedDataConKey
+ = unicodeSyntax (char '★') (char '*')
+
+ | tc `hasKey` tYPETyConKey
+ , [TyConApp ptr_rep []] <- tys
+ , ptr_rep `hasKey` ptrRepUnliftedDataConKey
+ = char '#'
| otherwise
= ppr_deflt
@@ -2669,27 +2684,33 @@ pprTyTcApp p tc tys
ppr_deflt = pprTcAppTy p ppr_type tc tys
pprTcAppTy :: TyPrec -> (TyPrec -> Type -> SDoc) -> TyCon -> [Type] -> SDoc
-pprTcAppTy = pprTcApp id
+pprTcAppTy p pp tc tys
+ = getPprStyle $ \style -> pprTcApp style id p pp tc tys
pprTcAppCo :: TyPrec -> (TyPrec -> Coercion -> SDoc)
-> TyCon -> [Coercion] -> SDoc
-pprTcAppCo = pprTcApp (pFst . coercionKind)
+pprTcAppCo p pp tc cos
+ = getPprStyle $ \style ->
+ pprTcApp style (pFst . coercionKind) p pp tc cos
-pprTcApp :: (a -> Type) -> TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc
+pprTcApp :: PprStyle
+ -> (a -> Type) -> TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc
-- Used for both types and coercions, hence polymorphism
-pprTcApp _ _ pp tc [ty]
+pprTcApp _ _ _ pp tc [ty]
| tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty)
| tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
-pprTcApp to_type p pp tc tys
- | Just sort <- tyConTuple_maybe tc
+pprTcApp style to_type p pp tc tys
+ | not (debugStyle style)
+ , Just sort <- tyConTuple_maybe tc
, let arity = tyConArity tc
, arity == length tys
, let num_to_drop = case sort of UnboxedTuple -> arity `div` 2
_ -> 0
= pprTupleApp p pp tc sort (drop num_to_drop tys)
- | Just dc <- isPromotedDataCon_maybe tc
+ | not (debugStyle style)
+ , Just dc <- isPromotedDataCon_maybe tc
, let dc_tc = dataConTyCon dc
, Just tup_sort <- tyConTuple_maybe dc_tc
, let arity = tyConArity dc_tc -- E.g. 3 for (,,) k1 k2 k3 t1 t2 t3
@@ -2700,7 +2721,6 @@ pprTcApp to_type p pp tc tys
| otherwise
= sdocWithDynFlags $ \dflags ->
- getPprStyle $ \style ->
pprTcApp_help to_type p pp tc tys dflags style
where
diff --git a/compiler/types/TyCoRep.hs-boot b/compiler/types/TyCoRep.hs-boot
index 76a5abf2f1..5236bcc45f 100644
--- a/compiler/types/TyCoRep.hs-boot
+++ b/compiler/types/TyCoRep.hs-boot
@@ -11,6 +11,8 @@ data LeftOrRight
data UnivCoProvenance
data TCvSubst
+mkForAllTys :: [TyBinder] -> Type -> Type
+
type PredType = Type
type Kind = Type
type ThetaType = [PredType]
diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs
index e6fe3511d4..5d017325cc 100644
--- a/compiler/types/TyCon.hs
+++ b/compiler/types/TyCon.hs
@@ -15,6 +15,7 @@ module TyCon(
AlgTyConRhs(..), visibleDataCons,
AlgTyConFlav(..), isNoParent,
FamTyConFlav(..), Role(..), Injectivity(..),
+ RuntimeRepInfo(..),
-- ** Field labels
tyConFieldLabels, tyConFieldLabelEnv,
@@ -82,6 +83,8 @@ module TyCon(
newTyConRhs, newTyConEtadArity, newTyConEtadRhs,
unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe,
algTcFields,
+ tyConRuntimeRepInfo,
+ tyConBinders, tyConResKind,
-- ** Manipulating TyCons
expandSynTyCon_maybe,
@@ -96,7 +99,7 @@ module TyCon(
-- * Primitive representations of Types
PrimRep(..), PrimElemRep(..),
- tyConPrimRep, isVoidRep, isGcPtrRep,
+ isVoidRep, isGcPtrRep,
primRepSizeW, primElemRepSizeB,
primRepIsFloat,
@@ -107,7 +110,9 @@ module TyCon(
#include "HsVersions.h"
-import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType )
+import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, TyBinder, mkForAllTys )
+import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind
+ , vecCountTyCon, vecElemTyCon, liftedTypeKind )
import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars, dataConFieldLabels )
import Binary
@@ -127,6 +132,7 @@ import FieldLabel
import Constants
import Util
import Unique( tyConRepNameUnique, dataConRepNameUnique )
+import UniqSet
import Module
import qualified Data.Data as Data
@@ -322,12 +328,13 @@ it's worth noting that (~#)'s parameters are at role N. Promoted data
constructors' type arguments are at role R. All kind arguments are at role
N.
-Note [Unboxed tuple levity vars]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The contents of an unboxed tuple may be boxed or unboxed. Accordingly,
-the kind of the unboxed tuple constructor is sort-polymorphic. For example,
+Note [Unboxed tuple RuntimeRep vars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The contents of an unboxed tuple may have any representation. Accordingly,
+the kind of the unboxed tuple constructor is runtime-representation
+polymorphic. For example,
- (#,#) :: forall (v :: Levity) (w :: Levity). TYPE v -> TYPE w -> #
+ (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). TYPE q -> TYPE r -> #
These extra tyvars (v and w) cause some delicate processing around tuples,
where we used to be able to assume that the tycon arity and the
@@ -390,6 +397,13 @@ data TyCon
tyConName :: Name, -- ^ Name of the constructor
+ tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind.
+ -- length tyConBinders == tyConArity.
+ -- This is a cached value and is redundant with
+ -- the tyConKind.
+
+ tyConResKind :: Kind, -- ^ Cached result kind
+
tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just
-- the return kind)
@@ -420,6 +434,13 @@ data TyCon
tyConName :: Name, -- ^ Name of the constructor
+ tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind.
+ -- length tyConBinders == tyConArity.
+ -- This is a cached value and is redundant with
+ -- the tyConKind.
+
+ tyConResKind :: Kind, -- ^ Cached result kind
+
tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just
-- the return kind)
@@ -483,6 +504,13 @@ data TyCon
tyConName :: Name, -- ^ Name of the constructor
+ tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind.
+ -- length tyConBinders == tyConArity.
+ -- This is a cached value and is redundant with
+ -- the tyConKind.
+
+ tyConResKind :: Kind, -- ^ Cached result kind.
+
tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just
-- the return kind)
@@ -511,6 +539,13 @@ data TyCon
tyConName :: Name, -- ^ Name of the constructor
+ tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind.
+ -- length tyConBinders == tyConArity.
+ -- This is a cached value and is redundant with
+ -- the tyConKind.
+
+ tyConResKind :: Kind, -- ^ Cached result kind
+
tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just
-- the return kind)
@@ -558,6 +593,13 @@ data TyCon
tyConName :: Name, -- ^ Name of the constructor
+ tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind.
+ -- length tyConBinders == tyConArity.
+ -- This is a cached value and is redundant with
+ -- the tyConKind.
+
+ tyConResKind :: Kind, -- ^ Cached result kind
+
tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just
-- the return kind)
@@ -569,11 +611,6 @@ data TyCon
-- This list has the same length as tyConTyVars
-- See also Note [TyCon Role signatures]
- primTyConRep :: PrimRep,-- ^ Many primitive tycons are unboxed, but
- -- some are boxed (represented by
- -- pointers). This 'PrimRep' holds that
- -- information. Only relevant if tyConKind = #
-
isUnlifted :: Bool, -- ^ Most primitive tycons are unlifted (may
-- not contain bottom) but other are lifted,
-- e.g. @RealWorld@
@@ -585,13 +622,19 @@ data TyCon
-- | Represents promoted data constructor.
| PromotedDataCon { -- See Note [Promoted data constructors]
- tyConUnique :: Unique, -- ^ Same Unique as the data constructor
- tyConName :: Name, -- ^ Same Name as the data constructor
- tyConArity :: Arity,
- tyConKind :: Kind, -- ^ Translated type of the data constructor
- tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars
- dataCon :: DataCon,-- ^ Corresponding data constructor
- tcRepName :: TyConRepName
+ tyConUnique :: Unique, -- ^ Same Unique as the data constructor
+ tyConName :: Name, -- ^ Same Name as the data constructor
+ tyConArity :: Arity,
+ tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind.
+ -- length tyConBinders == tyConArity.
+ -- This is a cached value and is redundant with
+ -- the tyConKind.
+ tyConResKind :: Kind, -- ^ Cached result kind
+ tyConKind :: Kind, -- ^ Type of the data constructor
+ tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars
+ dataCon :: DataCon,-- ^ Corresponding data constructor
+ tcRepName :: TyConRepName,
+ promDcRepInfo :: RuntimeRepInfo -- ^ See comments with 'RuntimeRepInfo'
}
-- | These exist only during a recursive type/class type-checking knot.
@@ -600,6 +643,12 @@ data TyCon
tyConName :: Name,
tyConUnsat :: Bool, -- ^ can this tycon be unsaturated?
tyConArity :: Arity,
+ tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind.
+ -- length tyConBinders == tyConArity.
+ -- This is a cached value and is redundant with
+ -- the tyConKind.
+ tyConResKind :: Kind, -- ^ Cached result kind
+
tyConKind :: Kind
}
deriving Typeable
@@ -668,6 +717,19 @@ data AlgTyConRhs
-- again check Trac #1072.
}
+-- | Some promoted datacons signify extra info relevant to GHC. For example,
+-- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep'
+-- constructor of 'PrimRep'. This data structure allows us to store this
+-- information right in the 'TyCon'. The other approach would be to look
+-- up things like @RuntimeRep@'s @PrimRep@ by known-key every time.
+data RuntimeRepInfo
+ = NoRRI -- ^ an ordinary promoted data con
+ | RuntimeRep ([Type] -> PrimRep)
+ -- ^ A constructor of @RuntimeRep@. The argument to the function should
+ -- be the list of arguments to the promoted datacon.
+ | VecCount Int -- ^ A constructor of @VecCount@
+ | VecElem PrimElemRep -- ^ A constructor of @VecElem@
+
-- | Extract those 'DataCon's that we are able to learn about. Note
-- that visibility in this sense does not correspond to visibility in
-- the context of any particular user program!
@@ -1132,14 +1194,16 @@ So we compromise, and move their Kind calculation to the call site.
-- | Given the name of the function type constructor and it's kind, create the
-- corresponding 'TyCon'. It is reccomended to use 'TyCoRep.funTyCon' if you want
-- this functionality
-mkFunTyCon :: Name -> Kind -> Name -> TyCon
-mkFunTyCon name kind rep_nm
+mkFunTyCon :: Name -> [TyBinder] -> Name -> TyCon
+mkFunTyCon name binders rep_nm
= FunTyCon {
- tyConUnique = nameUnique name,
- tyConName = name,
- tyConKind = kind,
- tyConArity = 2,
- tcRepName = rep_nm
+ tyConUnique = nameUnique name,
+ tyConName = name,
+ tyConBinders = binders,
+ tyConResKind = liftedTypeKind,
+ tyConKind = mkForAllTys binders liftedTypeKind,
+ tyConArity = 2,
+ tcRepName = rep_nm
}
-- | This is the making of an algebraic 'TyCon'. Notably, you have to
@@ -1147,7 +1211,8 @@ mkFunTyCon name kind rep_nm
-- type constructor - you can get hold of it easily (see Generics
-- module)
mkAlgTyCon :: Name
- -> Kind -- ^ Kind of the resulting 'TyCon'
+ -> [TyBinder] -- ^ Binders of the resulting 'TyCon'
+ -> Kind -- ^ Result kind
-> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'.
-- Arity is inferred from the length of this
-- list
@@ -1161,11 +1226,13 @@ mkAlgTyCon :: Name
-> RecFlag -- ^ Is the 'TyCon' recursive?
-> Bool -- ^ Was the 'TyCon' declared with GADT syntax?
-> TyCon
-mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn
+mkAlgTyCon name binders res_kind tyvars roles cType stupid rhs parent is_rec gadt_syn
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
- tyConKind = kind,
+ tyConBinders = binders,
+ tyConResKind = res_kind,
+ tyConKind = mkForAllTys binders res_kind,
tyConArity = length tyvars,
tyConTyVars = tyvars,
tcRoles = roles,
@@ -1179,26 +1246,30 @@ mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn
}
-- | Simpler specialization of 'mkAlgTyCon' for classes
-mkClassTyCon :: Name -> Kind -> [TyVar] -> [Role] -> AlgTyConRhs -> Class
+mkClassTyCon :: Name -> [TyBinder]
+ -> [TyVar] -> [Role] -> AlgTyConRhs -> Class
-> RecFlag -> Name -> TyCon
-mkClassTyCon name kind tyvars roles rhs clas is_rec tc_rep_name
- = mkAlgTyCon name kind tyvars roles Nothing [] rhs
+mkClassTyCon name binders tyvars roles rhs clas is_rec tc_rep_name
+ = mkAlgTyCon name binders constraintKind tyvars roles Nothing [] rhs
(ClassTyCon clas tc_rep_name)
is_rec False
mkTupleTyCon :: Name
- -> Kind -- ^ Kind of the resulting 'TyCon'
+ -> [TyBinder]
+ -> Kind -- ^ Result kind of the 'TyCon'
-> Arity -- ^ Arity of the tuple
-> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'
-> DataCon
-> TupleSort -- ^ Whether the tuple is boxed or unboxed
-> AlgTyConFlav
-> TyCon
-mkTupleTyCon name kind arity tyvars con sort parent
+mkTupleTyCon name binders res_kind arity tyvars con sort parent
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
- tyConKind = kind,
+ tyConBinders = binders,
+ tyConResKind = res_kind,
+ tyConKind = mkForAllTys binders res_kind,
tyConArity = arity,
tyConTyVars = tyvars,
tcRoles = replicate arity Representational,
@@ -1218,75 +1289,91 @@ mkTupleTyCon name kind arity tyvars con sort parent
-- TcErrors sometimes calls typeKind.
-- See also Note [Kind checking recursive type and class declarations]
-- in TcTyClsDecls.
-mkTcTyCon :: Name -> Kind -> Bool -- ^ Can this be unsaturated?
- -> Arity
+mkTcTyCon :: Name -> [TyBinder] -> Kind -- ^ /result/ kind only
+ -> Bool -- ^ Can this be unsaturated?
-> TyCon
-mkTcTyCon name kind unsat arity
+mkTcTyCon name binders res_kind unsat
= TcTyCon { tyConUnique = getUnique name
, tyConName = name
- , tyConKind = kind
+ , tyConBinders = binders
+ , tyConResKind = res_kind
+ , tyConKind = mkForAllTys binders res_kind
, tyConUnsat = unsat
- , tyConArity = arity }
+ , tyConArity = length binders }
-- | Create an unlifted primitive 'TyCon', such as @Int#@
-mkPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon
-mkPrimTyCon name kind roles rep
- = mkPrimTyCon' name kind roles rep True (Just $ mkPrelTyConRepName name)
+mkPrimTyCon :: Name -> [TyBinder]
+ -> Kind -- ^ /result/ kind
+ -> [Role] -> TyCon
+mkPrimTyCon name binders res_kind roles
+ = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name)
-- | Kind constructors
-mkKindTyCon :: Name -> Kind -> [Role] -> Name -> TyCon
-mkKindTyCon name kind roles rep_nm
+mkKindTyCon :: Name -> [TyBinder]
+ -> Kind -- ^ /result/ kind
+ -> [Role] -> Name -> TyCon
+mkKindTyCon name binders res_kind roles rep_nm
= tc
where
- tc = mkPrimTyCon' name kind roles PtrRep False (Just rep_nm)
- -- PtrRep because kinds have kind *.
+ tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm)
-- | Create a lifted primitive 'TyCon' such as @RealWorld@
-mkLiftedPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon
-mkLiftedPrimTyCon name kind roles rep
- = mkPrimTyCon' name kind roles rep False Nothing
-
-mkPrimTyCon' :: Name -> Kind -> [Role] -> PrimRep
+mkLiftedPrimTyCon :: Name -> [TyBinder]
+ -> Kind -- ^ /result/ kind
+ -> [Role] -> TyCon
+mkLiftedPrimTyCon name binders res_kind roles
+ = mkPrimTyCon' name binders res_kind roles False Nothing
+
+mkPrimTyCon' :: Name -> [TyBinder]
+ -> Kind -- ^ /result/ kind
+ -> [Role]
-> Bool -> Maybe TyConRepName -> TyCon
-mkPrimTyCon' name kind roles rep is_unlifted rep_nm
+mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm
= PrimTyCon {
tyConName = name,
tyConUnique = nameUnique name,
- tyConKind = kind,
+ tyConBinders = binders,
+ tyConResKind = res_kind,
+ tyConKind = mkForAllTys binders res_kind,
tyConArity = length roles,
tcRoles = roles,
- primTyConRep = rep,
isUnlifted = is_unlifted,
primRepName = rep_nm
}
-- | Create a type synonym 'TyCon'
-mkSynonymTyCon :: Name -> Kind -> [TyVar] -> [Role] -> Type -> TyCon
-mkSynonymTyCon name kind tyvars roles rhs
+mkSynonymTyCon :: Name -> [TyBinder] -> Kind -- ^ /result/ kind
+ -> [TyVar] -> [Role] -> Type -> TyCon
+mkSynonymTyCon name binders res_kind tyvars roles rhs
= SynonymTyCon {
- tyConName = name,
- tyConUnique = nameUnique name,
- tyConKind = kind,
- tyConArity = length tyvars,
- tyConTyVars = tyvars,
- tcRoles = roles,
- synTcRhs = rhs
+ tyConName = name,
+ tyConUnique = nameUnique name,
+ tyConBinders = binders,
+ tyConResKind = res_kind,
+ tyConKind = mkForAllTys binders res_kind,
+ tyConArity = length tyvars,
+ tyConTyVars = tyvars,
+ tcRoles = roles,
+ synTcRhs = rhs
}
-- | Create a type family 'TyCon'
-mkFamilyTyCon:: Name -> Kind -> [TyVar] -> Maybe Name -> FamTyConFlav
- -> Maybe Class -> Injectivity -> TyCon
-mkFamilyTyCon name kind tyvars resVar flav parent inj
+mkFamilyTyCon :: Name -> [TyBinder] -> Kind -- ^ /result/ kind
+ -> [TyVar] -> Maybe Name -> FamTyConFlav
+ -> Maybe Class -> Injectivity -> TyCon
+mkFamilyTyCon name binders res_kind tyvars resVar flav parent inj
= FamilyTyCon
- { tyConUnique = nameUnique name
- , tyConName = name
- , tyConKind = kind
- , tyConArity = length tyvars
- , tyConTyVars = tyvars
- , famTcResVar = resVar
- , famTcFlav = flav
- , famTcParent = parent
- , famTcInj = inj
+ { tyConUnique = nameUnique name
+ , tyConName = name
+ , tyConBinders = binders
+ , tyConResKind = res_kind
+ , tyConKind = mkForAllTys binders res_kind
+ , tyConArity = length tyvars
+ , tyConTyVars = tyvars
+ , famTcResVar = resVar
+ , famTcFlav = flav
+ , famTcParent = parent
+ , famTcInj = inj
}
@@ -1294,16 +1381,20 @@ mkFamilyTyCon name kind tyvars resVar flav parent inj
-- Somewhat dodgily, we give it the same Name
-- as the data constructor itself; when we pretty-print
-- the TyCon we add a quote; see the Outputable TyCon instance
-mkPromotedDataCon :: DataCon -> Name -> TyConRepName -> Kind -> [Role] -> TyCon
-mkPromotedDataCon con name rep_name kind roles
+mkPromotedDataCon :: DataCon -> Name -> TyConRepName -> [TyBinder] -> Kind -> [Role]
+ -> RuntimeRepInfo -> TyCon
+mkPromotedDataCon con name rep_name binders res_kind roles rep_info
= PromotedDataCon {
- tyConUnique = nameUnique name,
- tyConName = name,
- tyConArity = arity,
- tcRoles = roles,
- tyConKind = kind,
- dataCon = con,
- tcRepName = rep_name
+ tyConUnique = nameUnique name,
+ tyConName = name,
+ tyConArity = arity,
+ tcRoles = roles,
+ tyConBinders = binders,
+ tyConResKind = res_kind,
+ tyConKind = mkForAllTys binders res_kind,
+ dataCon = con,
+ tcRepName = rep_name,
+ promDcRepInfo = rep_info
}
where
arity = length roles
@@ -1321,16 +1412,8 @@ isAbstractTyCon _ = False
-- Used when recovering from errors
makeTyConAbstract :: TyCon -> TyCon
makeTyConAbstract tc
- = PrimTyCon { tyConName = name,
- tyConUnique = nameUnique name,
- tyConKind = tyConKind tc,
- tyConArity = tyConArity tc,
- tcRoles = tyConRoles tc,
- primTyConRep = PtrRep,
- isUnlifted = False,
- primRepName = Nothing }
- where
- name = tyConName tc
+ = mkTcTyCon (tyConName tc) (tyConBinders tc) (tyConResKind tc)
+ (mightBeUnsaturatedTyCon tc)
-- | Does this 'TyCon' represent something that cannot be defined in Haskell?
isPrimTyCon :: TyCon -> Bool
@@ -1642,12 +1725,18 @@ isPromotedDataCon_maybe _ = Nothing
-- | Is this tycon really meant for use at the kind level? That is,
-- should it be permitted without -XDataKinds?
isKindTyCon :: TyCon -> Bool
-isKindTyCon tc = isLiftedTypeKindTyConName (tyConName tc) ||
- tc `hasKey` constraintKindTyConKey ||
- tc `hasKey` tYPETyConKey ||
- tc `hasKey` levityTyConKey ||
- tc `hasKey` liftedDataConKey ||
- tc `hasKey` unliftedDataConKey
+isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys
+
+-- | These TyCons should be allowed at the kind level, even without
+-- -XDataKinds.
+kindTyConKeys :: UniqSet Unique
+kindTyConKeys = unionManyUniqSets
+ ( mkUniqSet [ liftedTypeKindTyConKey, starKindTyConKey, unicodeStarKindTyConKey
+ , constraintKindTyConKey, tYPETyConKey ]
+ : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon
+ , vecCountTyCon, vecElemTyCon ] )
+ where
+ tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc)
isLiftedTypeKindTyConName :: Name -> Bool
isLiftedTypeKindTyConName
@@ -1855,11 +1944,6 @@ newTyConCo tc = case newTyConCo_maybe tc of
Just co -> co
Nothing -> pprPanic "newTyConCo" (ppr tc)
--- | Find the primitive representation of a 'TyCon'
-tyConPrimRep :: TyCon -> PrimRep
-tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
-tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep
-
-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context
-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration
-- @data Eq a => T a ...@
@@ -1929,6 +2013,12 @@ tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ })
= Just ax
tyConFamilyCoercion_maybe _ = Nothing
+-- | Extract any 'RuntimeRepInfo' from this TyCon
+tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo
+tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri
+tyConRuntimeRepInfo _ = NoRRI
+ -- could panic in that second case. But Douglas Adams told me not to.
+
{-
************************************************************************
* *
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 824aa9d752..bca64c2efc 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -41,7 +41,7 @@ module Type (
splitForAllTy_maybe, splitForAllTys, splitForAllTy,
splitPiTy_maybe, splitPiTys, splitPiTy,
splitNamedPiTys,
- mkPiType, mkPiTypes, mkPiTypesPreferFunTy,
+ mkPiType, mkPiTypes, mkTyBindersPreferAnon,
piResultTy, piResultTys,
applyTysX, dropForAlls,
@@ -58,7 +58,6 @@ module Type (
splitPiTysInvisible, filterOutInvisibleTypes,
filterOutInvisibleTyVars, partitionInvisibles,
synTyConResKind,
- tyConBinders,
-- Analyzing types
TyCoMapper(..), mapType, mapCoercion,
@@ -103,9 +102,9 @@ module Type (
-- (Lifting and boxity)
isUnliftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
isPrimitiveType, isStrictType,
- isLevityTy, isLevityVar, isLevityKindedTy,
- dropLevityArgs,
- getLevity, getLevityFromKind,
+ isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,
+ dropRuntimeRepArgs,
+ getRuntimeRep, getRuntimeRepFromKind,
-- * Main data types representing Kinds
Kind,
@@ -114,7 +113,7 @@ module Type (
typeKind,
-- ** Common Kind
- liftedTypeKind, unliftedTypeKind,
+ liftedTypeKind,
-- * Type free variables
tyCoVarsOfType, tyCoVarsOfTypes, tyCoVarsOfTypeAcc,
@@ -143,7 +142,7 @@ module Type (
tyConsOfType,
-- * Type representation for the code generator
- typePrimRep, typeRepArity,
+ typePrimRep, typeRepArity, kindPrimRep, tyConPrimRep,
-- * Main type substitution data types
TvSubstEnv, -- Representation widely visible
@@ -310,7 +309,8 @@ coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc t
coreView _ = Nothing
-- | Like 'coreView', but it also "expands" @Constraint@ to become
--- @TYPE Lifted@.
+-- @TYPE PtrRepLifted@.
+{-# INLINE coreViewOneStarKind #-}
coreViewOneStarKind :: Type -> Maybe Type
coreViewOneStarKind ty
| Just ty' <- coreView ty = Just ty'
@@ -1077,27 +1077,28 @@ mkCastTy ty co = -- NB: don't check if the coercion "from" type matches here;
= split_apps (t2:args) t1 co
split_apps args (TyConApp tc tc_args) co
| mightBeUnsaturatedTyCon tc
- = affix_co (tyConKind tc) (mkTyConTy tc) (tc_args `chkAppend` args) co
+ = affix_co (tyConBinders tc) (mkTyConTy tc) (tc_args `chkAppend` args) co
| otherwise -- not decomposable... but it may still be oversaturated
= let (non_decomp_args, decomp_args) = splitAt (tyConArity tc) tc_args
saturated_tc = mkTyConApp tc non_decomp_args
in
- affix_co (typeKind saturated_tc) saturated_tc (decomp_args `chkAppend` args) co
+ affix_co (fst $ splitPiTys $ typeKind saturated_tc)
+ saturated_tc (decomp_args `chkAppend` args) co
split_apps args (ForAllTy (Anon arg) res) co
- = affix_co (tyConKind funTyCon) (mkTyConTy funTyCon)
+ = affix_co (tyConBinders funTyCon) (mkTyConTy funTyCon)
(arg : res : args) co
split_apps args ty co
- = affix_co (typeKind ty) ty args co
+ = affix_co (fst $ splitPiTys $ typeKind ty)
+ ty args co
-- having broken everything apart, this figures out the point at which there
-- are no more dependent quantifications, and puts the cast there
affix_co _ ty [] co = no_double_casts ty co
- affix_co kind ty args co
+ affix_co bndrs ty args co
-- if kind contains any dependent quantifications, we can't push.
-- apply arguments until it doesn't
- = let (bndrs, _inner_ki) = splitPiTys kind
- (no_dep_bndrs, some_dep_bndrs) = spanEnd isAnonBinder bndrs
+ = let (no_dep_bndrs, some_dep_bndrs) = spanEnd isAnonBinder bndrs
(some_dep_args, rest_args) = splitAtList some_dep_bndrs args
dep_subst = zipTyBinderSubst some_dep_bndrs some_dep_args
used_no_dep_bndrs = takeList rest_args no_dep_bndrs
@@ -1212,10 +1213,10 @@ repType ty
| isUnboxedTupleTyCon tc
= if null tys
then UnaryRep voidPrimTy -- See Note [Nullary unboxed tuple]
- else UbxTupleRep (concatMap (flattenRepType . go rec_nts) non_levity_tys)
+ else UbxTupleRep (concatMap (flattenRepType . go rec_nts) non_rr_tys)
where
- -- See Note [Unboxed tuple levity vars] in TyCon
- non_levity_tys = dropLevityArgs tys
+ -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+ non_rr_tys = dropRuntimeRepArgs tys
go rec_nts (CastTy ty _)
= go rec_nts ty
@@ -1230,16 +1231,31 @@ repType ty
-- | Discovers the primitive representation of a more abstract 'UnaryType'
typePrimRep :: UnaryType -> PrimRep
-typePrimRep ty
- = case repType ty of
- UbxTupleRep _ -> pprPanic "typePrimRep: UbxTupleRep" (ppr ty)
- UnaryRep rep -> go rep
- where go (TyConApp tc _) = tyConPrimRep tc
- go (ForAllTy _ _) = PtrRep
- go (AppTy _ _) = PtrRep -- See Note [AppTy rep]
- go (TyVarTy _) = PtrRep
- go (CastTy ty _) = go ty
- go _ = pprPanic "typePrimRep: UnaryRep" (ppr ty)
+typePrimRep ty = kindPrimRep (typeKind ty)
+
+-- | Find the primitive representation of a 'TyCon'. Defined here to
+-- avoid module loops. Call this only on unlifted tycons.
+tyConPrimRep :: TyCon -> PrimRep
+tyConPrimRep tc = kindPrimRep res_kind
+ where
+ res_kind = tyConResKind tc
+
+-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep' of values
+-- of types of this kind.
+kindPrimRep :: Kind -> PrimRep
+kindPrimRep ki | Just ki' <- coreViewOneStarKind ki = kindPrimRep ki'
+kindPrimRep (TyConApp typ [runtime_rep])
+ = ASSERT( typ `hasKey` tYPETyConKey )
+ go runtime_rep
+ where
+ go rr | Just rr' <- coreView rr = go rr'
+ go (TyConApp rr_dc args)
+ | RuntimeRep fun <- tyConRuntimeRepInfo rr_dc
+ = fun args
+ go rr = pprPanic "kindPrimRep.go" (ppr rr)
+kindPrimRep ki = WARN( True
+ , text "kindPrimRep defaulting to PtrRep on" <+> ppr ki )
+ PtrRep -- this can happen legitimately for, e.g., Any
typeRepArity :: Arity -> Type -> RepArity
typeRepArity 0 _ = 0
@@ -1250,7 +1266,8 @@ typeRepArity n ty = case repType ty of
isVoidTy :: Type -> Bool
-- True if the type has zero width
isVoidTy ty = case repType ty of
- UnaryRep (TyConApp tc _) -> isVoidRep (tyConPrimRep tc)
+ UnaryRep (TyConApp tc _) -> isUnliftedTyCon tc &&
+ isVoidRep (tyConPrimRep tc)
_ -> False
{-
@@ -1274,10 +1291,6 @@ mkNamedForAllTy :: TyVar -> VisibilityFlag -> Type -> Type
mkNamedForAllTy tv vis = ASSERT( isTyVar tv )
ForAllTy (Named tv vis)
--- | Wraps foralls over the type using the provided 'TyVar's from left to right
-mkForAllTys :: [TyBinder] -> Type -> Type
-mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
-
-- | Like mkForAllTys, but assumes all variables are dependent and invisible,
-- a common case
mkInvForAllTys :: [TyVar] -> Type -> Type
@@ -1309,23 +1322,23 @@ mkPiType v ty
mkPiTypes vs ty = foldr mkPiType ty vs
--- | Given a list of type-level vars, makes ForAllTys, preferring
+-- | Given a list of type-level vars and a result type, makes TyBinders, preferring
-- anonymous binders if the variable is, in fact, not dependent.
-- All binders are /visible/.
-mkPiTypesPreferFunTy :: [TyVar] -> Type -> Type
-mkPiTypesPreferFunTy vars inner_ty = fst $ go vars inner_ty
+mkTyBindersPreferAnon :: [TyVar] -> Type -> [TyBinder]
+mkTyBindersPreferAnon vars inner_ty = fst $ go vars inner_ty
where
- go :: [TyVar] -> Type -> (Type, VarSet) -- also returns the free vars
- go [] ty = (ty, tyCoVarsOfType ty)
- go (v:vs) ty | v `elemVarSet` fvs
- = ( mkForAllTy (Named v Visible) qty
+ go :: [TyVar] -> Type -> ([TyBinder], VarSet) -- also returns the free vars
+ go [] ty = ([], tyCoVarsOfType ty)
+ go (v:vs) ty | v `elemVarSet` fvs
+ = ( Named v Visible : binders
, fvs `delVarSet` v `unionVarSet` kind_vars )
| otherwise
- = ( mkForAllTy (Anon (tyVarKind v)) qty
+ = ( Anon (tyVarKind v) : binders
, fvs `unionVarSet` kind_vars )
where
- (qty, fvs) = go vs ty
- kind_vars = tyCoVarsOfType $ tyVarKind v
+ (binders, fvs) = go vs ty
+ kind_vars = tyCoVarsOfType $ tyVarKind v
-- | Take a ForAllTy apart, returning the list of tyvars and the result type.
-- This always succeeds, even if it returns only an empty list. Note that the
@@ -1454,9 +1467,6 @@ splitPiTysInvisible ty = split ty ty []
split orig_ty _ bndrs
= (reverse bndrs, orig_ty)
-tyConBinders :: TyCon -> [TyBinder]
-tyConBinders = fst . splitPiTys . tyConKind
-
applyTysX :: [TyVar] -> Type -> [Type] -> Type
-- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys
-- Assumes that (/\tvs. body_ty) is closed
@@ -1917,25 +1927,26 @@ isUnliftedType (ForAllTy (Named {}) ty) = isUnliftedType ty
isUnliftedType (TyConApp tc _) = isUnliftedTyCon tc
isUnliftedType _ = False
--- | Extract the levity classifier of a type. Panics if this is not possible.
-getLevity :: String -- ^ Printed in case of an error
- -> Type -> Type
-getLevity err ty = getLevityFromKind err (typeKind ty)
+-- | Extract the RuntimeRep classifier of a type. Panics if this is not possible.
+getRuntimeRep :: String -- ^ Printed in case of an error
+ -> Type -> Type
+getRuntimeRep err ty = getRuntimeRepFromKind err (typeKind ty)
--- | Extract the levity classifier of a type from its kind.
--- For example, getLevityFromKind * = Lifted; getLevityFromKind # = Unlifted.
+-- | Extract the RuntimeRep classifier of a type from its kind.
+-- For example, getRuntimeRepFromKind * = PtrRepLifted;
+-- getRuntimeRepFromKind # = PtrRepUnlifted.
-- Panics if this is not possible.
-getLevityFromKind :: String -- ^ Printed in case of an error
- -> Type -> Type
-getLevityFromKind err = go
+getRuntimeRepFromKind :: String -- ^ Printed in case of an error
+ -> Type -> Type
+getRuntimeRepFromKind err = go
where
go k | Just k' <- coreViewOneStarKind k = go k'
go k
| Just (tc, [arg]) <- splitTyConApp_maybe k
, tc `hasKey` tYPETyConKey
= arg
- go k = pprPanic "getLevity" (text err $$
- ppr k <+> dcolon <+> ppr (typeKind k))
+ go k = pprPanic "getRuntimeRep" (text err $$
+ ppr k <+> dcolon <+> ppr (typeKind k))
isUnboxedTupleType :: Type -> Bool
isUnboxedTupleType ty = case tyConAppTyCon_maybe ty of
@@ -2065,11 +2076,17 @@ cmpTypes ts1 ts2 = cmpTypesX rn_env ts1 ts2
cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse
-- See Note [Non-trivial definitional equality] in TyCoRep
-cmpTypeX env orig_t1 orig_t2 = go env k1 k2 `thenCmp` go env orig_t1 orig_t2
+cmpTypeX env orig_t1 orig_t2
+ = go env orig_t1 orig_t2 `thenCmp` go env k1 k2
+ -- NB: this ordering appears to be faster than the other
where
k1 = typeKind orig_t1
k2 = typeKind orig_t2
+ -- short-cut to handle comparing * against *.
+ -- appears to have a roughly 1% improvement in compile times
+ go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = EQ
+
go env t1 t2 | Just t1' <- coreViewOneStarKind t1 = go env t1' t2
go env t1 t2 | Just t2' <- coreViewOneStarKind t2 = go env t1 t2'
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index 8cafbfb4f1..ff0f45f725 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -14,6 +14,8 @@ module Util (
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy, stretchZipWith, zipWithAndUnzip,
+ zipWithLazy, zipWith3Lazy,
+
filterByList, filterByLists, partitionByList,
unzipWith,
@@ -322,6 +324,20 @@ zipLazy :: [a] -> [b] -> [(a,b)]
zipLazy [] _ = []
zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
+-- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list.
+-- The length of the output is always the same as the length of the first
+-- list.
+zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c]
+zipWithLazy _ [] _ = []
+zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs
+
+-- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists.
+-- The length of the output is always the same as the length of the first
+-- list.
+zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
+zipWith3Lazy _ [] _ _ = []
+zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs
+
-- | 'filterByList' takes a list of Bools and a list of some elements and
-- filters out these elements for which the corresponding value in the list of
-- Bools is False. This function does not check whether the lists have equal
diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs
index 5f283c6d3a..9daa16a170 100644
--- a/compiler/vectorise/Vectorise/Exp.hs
+++ b/compiler/vectorise/Vectorise/Exp.hs
@@ -360,7 +360,7 @@ vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err)
| v == pAT_ERROR_ID
= do
{ (vty, lty) <- vectAndLiftType ty
- ; return (mkCoreApps (Var v) [Type (getLevity "vectExpr" vty), Type vty, err'], mkCoreApps (Var v) [Type lty, err'])
+ ; return (mkCoreApps (Var v) [Type (getRuntimeRep "vectExpr" vty), Type vty, err'], mkCoreApps (Var v) [Type lty, err'])
}
where
err' = deAnnotate err
diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs
index a8bffbe962..4f3112850d 100644
--- a/compiler/vectorise/Vectorise/Generic/PData.hs
+++ b/compiler/vectorise/Vectorise/Generic/PData.hs
@@ -51,7 +51,8 @@ buildDataFamInst name' fam_tc vect_tc rhs
rep_ty = mkTyConApp rep_tc tys'
pat_tys = [mkTyConApp vect_tc tys']
rep_tc = mkAlgTyCon name'
- (mkPiTypesPreferFunTy tyvars' liftedTypeKind)
+ (mkTyBindersPreferAnon tyvars' liftedTypeKind)
+ liftedTypeKind
tyvars'
(map (const Nominal) tyvars')
Nothing
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 7b00a5c1ef..0bcdf0c4a8 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -360,7 +360,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
origName = tyConName origTyCon
vectName = tyConName vectTyCon
- mkSyn canonName ty = mkSynonymTyCon canonName (typeKind ty) [] [] ty
+ mkSyn canonName ty = mkSynonymTyCon canonName [] (typeKind ty) [] [] ty
defDataCons
| isAbstract = return ()
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 03e7d27d0e..4847aa87f1 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -64,7 +64,7 @@ vectTyConDecl tycon name'
(tyConTyVars tycon) -- keep original type vars
(map (const Nominal) (tyConRoles tycon)) -- all role are N for safety
theta' -- superclasses
- (tyConKind tycon) -- keep original kind
+ (tyConBinders tycon) -- keep original kind
(snd . classTvsFds $ cls) -- keep the original functional dependencies
[] -- no associated types (for the moment)
methods' -- method info
@@ -103,7 +103,8 @@ vectTyConDecl tycon name'
; tc_rep_name <- mkDerivedName mkTyConRepOcc name'
; return $ mkAlgTyCon
name' -- new name
- (tyConKind tycon) -- keep original kind
+ (tyConBinders tycon)
+ (tyConResKind tycon) -- keep original kind
(tyConTyVars tycon) -- keep original type vars
(map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety
Nothing
diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs
index 88191c1011..cc94bac30f 100644
--- a/libraries/base/Data/Data.hs
+++ b/libraries/base/Data/Data.hs
@@ -114,7 +114,7 @@ import Data.Monoid
import Data.Ord
import Data.Typeable
import Data.Version( Version(..) )
-import GHC.Base hiding (Any)
+import GHC.Base hiding (Any, IntRep, FloatRep)
import GHC.List
import GHC.Num
import GHC.Read
diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index efec62f7d8..87e5c88c76 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -10,6 +10,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeApplications #-}
-----------------------------------------------------------------------------
-- |
@@ -249,18 +250,6 @@ tyConOf = typeRepTyCon . typeRep
tcFun :: TyCon
tcFun = tyConOf (Proxy :: Proxy (Int -> Int))
-tcList :: TyCon
-tcList = tyConOf (Proxy :: Proxy [])
-
-tcTYPE :: TyCon
-tcTYPE = tyConOf (Proxy :: Proxy TYPE)
-
-tc'Lifted :: TyCon
-tc'Lifted = tyConOf (Proxy :: Proxy 'Lifted)
-
-tc'Unlifted :: TyCon
-tc'Unlifted = tyConOf (Proxy :: Proxy 'Unlifted)
-
-- | Adds a TypeRep argument to a TypeRep.
mkAppTy :: TypeRep -> TypeRep -> TypeRep
{-# INLINE mkAppTy #-}
@@ -364,10 +353,19 @@ instance Show TypeRep where
showsPrec p (TypeRep _ tycon kinds tys) =
case tys of
[] -> showsPrec p tycon
- [x@(TypeRep _ argCon _ _)]
+ [x]
| tycon == tcList -> showChar '[' . shows x . showChar ']'
- | tycon == tcTYPE && argCon == tc'Lifted -> showChar '*'
- | tycon == tcTYPE && argCon == tc'Unlifted -> showChar '#'
+ where
+ tcList = tyConOf @[] Proxy
+ [TypeRep _ ptrRepCon _ []]
+ | tycon == tcTYPE && ptrRepCon == tc'PtrRepLifted
+ -> showChar '*'
+ | tycon == tcTYPE && ptrRepCon == tc'PtrRepUnlifted
+ -> showChar '#'
+ where
+ tcTYPE = tyConOf @TYPE Proxy
+ tc'PtrRepLifted = tyConOf @'PtrRepLifted Proxy
+ tc'PtrRepUnlifted = tyConOf @'PtrRepUnlifted Proxy
[a,r] | tycon == tcFun -> showParen (p > 8) $
showsPrec 9 a .
showString " -> " .
diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs
index 88b9c39898..4231fcefa5 100644
--- a/libraries/base/GHC/Err.hs
+++ b/libraries/base/GHC/Err.hs
@@ -24,7 +24,7 @@
module GHC.Err( absentErr, error, errorWithoutStackTrace, undefined ) where
import GHC.CString ()
-import GHC.Types (Char, Levity)
+import GHC.Types (Char, RuntimeRep)
import GHC.Stack.Types
import GHC.Prim
import GHC.Integer () -- Make sure Integer is compiled first
@@ -33,7 +33,7 @@ import GHC.Integer () -- Make sure Integer is compiled first
import {-# SOURCE #-} GHC.Exception( errorCallWithCallStackException )
-- | 'error' stops execution and displays an error message.
-error :: forall (v :: Levity). forall (a :: TYPE v).
+error :: forall (r :: RuntimeRep). forall (a :: TYPE r).
HasCallStack => [Char] -> a
error s = raise# (errorCallWithCallStackException s ?callStack)
-- Bleh, we should be using 'GHC.Stack.callStack' instead of
@@ -44,7 +44,7 @@ error s = raise# (errorCallWithCallStackException s ?callStack)
-- | A variant of 'error' that does not produce a stack trace.
--
-- @since 4.9.0.0
-errorWithoutStackTrace :: forall (v :: Levity). forall (a :: TYPE v).
+errorWithoutStackTrace :: forall (r :: RuntimeRep). forall (a :: TYPE r).
[Char] -> a
errorWithoutStackTrace s =
-- we don't have withFrozenCallStack yet, so we just inline the definition
@@ -74,7 +74,7 @@ errorWithoutStackTrace s =
-- It is expected that compilers will recognize this and insert error
-- messages which are more appropriate to the context in which 'undefined'
-- appears.
-undefined :: forall (v :: Levity). forall (a :: TYPE v).
+undefined :: forall (r :: RuntimeRep). forall (a :: TYPE r).
HasCallStack => a
undefined = error "Prelude.undefined"
diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs
index 31e70ebd21..21f7bfd8b9 100755
--- a/libraries/base/GHC/Exts.hs
+++ b/libraries/base/GHC/Exts.hs
@@ -56,8 +56,8 @@ module GHC.Exts
-- * Equality
type (~~),
- -- * Levity polymorphism
- GHC.Prim.TYPE, Levity(..),
+ -- * Representation polymorphism
+ GHC.Prim.TYPE, RuntimeRep(..), VecCount(..), VecElem(..),
-- * Transform comprehensions
Down(..), groupWith, sortWith, the,
diff --git a/libraries/base/tests/T11334.hs b/libraries/base/tests/T11334.hs
index 22864d9c1d..2b4ac56c70 100644
--- a/libraries/base/tests/T11334.hs
+++ b/libraries/base/tests/T11334.hs
@@ -7,5 +7,5 @@ import GHC.Types
main :: IO ()
main = do
print (typeOf (Proxy :: Proxy 'Just))
- print (typeOf (Proxy :: Proxy (TYPE 'Lifted)))
- print (typeOf (Proxy :: Proxy (TYPE 'Unlifted)))
+ print (typeOf (Proxy :: Proxy (TYPE 'PtrRepLifted)))
+ print (typeOf (Proxy :: Proxy (TYPE 'PtrRepUnlifted)))
diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs
index 727811bdf4..6f9e09fdfb 100644
--- a/libraries/ghc-prim/GHC/Types.hs
+++ b/libraries/ghc-prim/GHC/Types.hs
@@ -30,10 +30,11 @@ module GHC.Types (
SPEC(..),
Nat, Symbol,
type (~~), Coercible,
- TYPE, Levity(..), Type, type (*), type (★), Constraint,
+ TYPE, RuntimeRep(..), Type, type (*), type (★), Constraint,
-- The historical type * should ideally be written as
-- `type *`, without the parentheses. But that's a true
-- pain to parse, and for little gain.
+ VecCount(..), VecElem(..),
-- * Runtime type representation
Module(..), TrName(..), TyCon(..)
@@ -57,13 +58,13 @@ infixr 5 :
data Constraint
-- | The kind of types with values. For example @Int :: Type@.
-type Type = TYPE 'Lifted
+type Type = TYPE 'PtrRepLifted
-- | A backward-compatible (pre-GHC 8.0) synonym for 'Type'
-type * = TYPE 'Lifted
+type * = TYPE 'PtrRepLifted
-- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type'
-type ★ = TYPE 'Lifted
+type ★ = TYPE 'PtrRepLifted
{- *********************************************************************
* *
@@ -330,17 +331,59 @@ you're reading this in 2023 then things went wrong). See #8326.
-- loops should be aggressively specialized.
data SPEC = SPEC | SPEC2
--- | GHC divides all proper types (that is, types that can perhaps be
--- inhabited, as distinct from type constructors or type-level data)
--- into two worlds: lifted types and unlifted types. For example,
--- @Int@ is lifted while @Int#@ is unlifted. Certain operations need
--- to be polymorphic in this distinction. A classic example is 'unsafeCoerce#',
--- which needs to be able to coerce between lifted and unlifted types.
--- To achieve this, we use kind polymorphism: lifted types have kind
--- @TYPE Lifted@ and unlifted ones have kind @TYPE Unlifted@. 'Levity'
--- is the kind of 'Lifted' and 'Unlifted'. @*@ is a synonym for @TYPE Lifted@
--- and @#@ is a synonym for @TYPE Unlifted@.
-data Levity = Lifted | Unlifted
+
+{- *********************************************************************
+* *
+ RuntimeRep
+* *
+********************************************************************* -}
+
+
+-- | GHC maintains a property that the kind of all inhabited types
+-- (as distinct from type constructors or type-level data) tells us
+-- the runtime representation of values of that type. This datatype
+-- encodes the choice of runtime value.
+-- Note that 'TYPE' is parameterised by 'RuntimeRep'; this is precisely
+-- what we mean by the fact that a type's kind encodes the runtime
+-- representation.
+--
+-- For boxed values (that is, values that are represented by a pointer),
+-- a further distinction is made, between lifted types (that contain ⊥),
+-- and unlifted ones (that don't).
+data RuntimeRep = VecRep VecCount VecElem -- ^ a SIMD vector type
+ | PtrRepLifted -- ^ lifted; represented by a pointer
+ | PtrRepUnlifted -- ^ unlifted; represented by a pointer
+ | VoidRep -- ^ erased entirely
+ | IntRep -- ^ signed, word-sized value
+ | WordRep -- ^ unsigned, word-sized value
+ | Int64Rep -- ^ signed, 64-bit value (on 32-bit only)
+ | Word64Rep -- ^ unsigned, 64-bit value (on 32-bit only)
+ | AddrRep -- ^ A pointer, but /not/ to a Haskell value
+ | FloatRep -- ^ a 32-bit floating point number
+ | DoubleRep -- ^ a 64-bit floating point number
+ | UnboxedTupleRep -- ^ An unboxed tuple; this doesn't specify a concrete rep
+
+-- See also Note [Wiring in RuntimeRep] in TysWiredIn
+
+-- | Length of a SIMD vector type
+data VecCount = Vec2
+ | Vec4
+ | Vec8
+ | Vec16
+ | Vec32
+ | Vec64
+
+-- | Element of a SIMD vector type
+data VecElem = Int8ElemRep
+ | Int16ElemRep
+ | Int32ElemRep
+ | Int64ElemRep
+ | Word8ElemRep
+ | Word16ElemRep
+ | Word32ElemRep
+ | Word64ElemRep
+ | FloatElemRep
+ | DoubleElemRep
{- *********************************************************************
* *
diff --git a/testsuite/tests/dependent/should_compile/T11405.hs b/testsuite/tests/dependent/should_compile/T11405.hs
index f80d994dc7..cdb713f118 100644
--- a/testsuite/tests/dependent/should_compile/T11405.hs
+++ b/testsuite/tests/dependent/should_compile/T11405.hs
@@ -5,5 +5,5 @@ module T11405 where
import GHC.Exts
import GHC.Stack
-x :: forall (v :: Levity) (a :: TYPE v). (?callStack :: CallStack) => a
+x :: forall (v :: RuntimeRep) (a :: TYPE v). (?callStack :: CallStack) => a
x = undefined
diff --git a/testsuite/tests/dependent/should_fail/BadTelescope4.stderr b/testsuite/tests/dependent/should_fail/BadTelescope4.stderr
index 158aec650d..2394f896ad 100644
--- a/testsuite/tests/dependent/should_fail/BadTelescope4.stderr
+++ b/testsuite/tests/dependent/should_fail/BadTelescope4.stderr
@@ -1,12 +1,12 @@
BadTelescope4.hs:9:1: error:
- • These kind and type variables: (a :: k1)
+ • These kind and type variables: (a :: k)
(c :: Proxy b)
(d :: Proxy a)
(x :: SameKind b d)
are out of dependency order. Perhaps try this ordering:
- k1
- (a :: k1)
+ k
+ (a :: k)
(b :: Proxy a)
(c :: Proxy b)
(d :: Proxy a)
diff --git a/testsuite/tests/dependent/should_fail/TypeSkolEscape.hs b/testsuite/tests/dependent/should_fail/TypeSkolEscape.hs
index 09845ed87e..bbec037487 100644
--- a/testsuite/tests/dependent/should_fail/TypeSkolEscape.hs
+++ b/testsuite/tests/dependent/should_fail/TypeSkolEscape.hs
@@ -5,4 +5,4 @@ module TypeSkolEscape where
import GHC.Types
import GHC.Exts
-type Bad = forall (v :: Levity) (a :: TYPE v). a
+type Bad = forall (v :: RuntimeRep) (a :: TYPE v). a
diff --git a/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr b/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr
index 1574c017ce..a4ce1e4131 100644
--- a/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr
+++ b/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr
@@ -1,7 +1,7 @@
TypeSkolEscape.hs:8:1: error:
- Quantified type's kind mentions quantified type variable
- (skolem escape)
- type: forall (v1 :: Levity) (a1 :: TYPE v1). a1
- of kind: TYPE v
- In the type synonym declaration for ‘Bad’
+ • Quantified type's kind mentions quantified type variable
+ (skolem escape)
+ type: forall (v1 :: RuntimeRep) (a1 :: TYPE v1). a1
+ of kind: TYPE v
+ • In the type synonym declaration for ‘Bad’
diff --git a/testsuite/tests/ghci/scripts/T4175.stdout b/testsuite/tests/ghci/scripts/T4175.stdout
index ef5b5c69c1..e1ef925bea 100644
--- a/testsuite/tests/ghci/scripts/T4175.stdout
+++ b/testsuite/tests/ghci/scripts/T4175.stdout
@@ -1,6 +1,4 @@
-type family A a b
- Kind: * -> * -> *
- -- Defined at T4175.hs:7:1
+type family A a b :: * -- Defined at T4175.hs:7:1
type instance A (B a) b = () -- Defined at T4175.hs:10:15
type instance A (Maybe a) a = a -- Defined at T4175.hs:9:15
type instance A Int Int = () -- Defined at T4175.hs:8:15
@@ -9,13 +7,11 @@ instance G B -- Defined at T4175.hs:34:10
data instance B () = MkB -- Defined at T4175.hs:13:15
type instance A (B a) b = () -- Defined at T4175.hs:10:15
class C a where
- type family D a b
- Kind: * -> * -> *
+ type family D a b :: *
-- Defined at T4175.hs:16:5
type instance D () () = Bool -- Defined at T4175.hs:22:10
type instance D Int () = String -- Defined at T4175.hs:19:10
-type family E a
- Kind: * -> *
+type family E a :: *
where
E () = Bool
E Int = String
diff --git a/testsuite/tests/ghci/scripts/T7627.stdout b/testsuite/tests/ghci/scripts/T7627.stdout
index 4b16acc1a2..ee6dfa4f10 100644
--- a/testsuite/tests/ghci/scripts/T7627.stdout
+++ b/testsuite/tests/ghci/scripts/T7627.stdout
@@ -29,11 +29,11 @@ data (#,#) (c :: TYPE a) (d :: TYPE b) = (#,#) c d
-- Defined in ‘GHC.Prim’
(,) :: a -> b -> (a, b)
(#,#)
- :: forall (a :: GHC.Types.Levity) (b :: GHC.Types.Levity) (c :: TYPE
- a) (d :: TYPE b).
+ :: forall (a :: GHC.Types.RuntimeRep) (b :: GHC.Types.RuntimeRep) (c :: TYPE
+ a) (d :: TYPE b).
c -> d -> (# c, d #)
( , ) :: a -> b -> (a, b)
(# , #)
- :: forall (a :: GHC.Types.Levity) (b :: GHC.Types.Levity) (c :: TYPE
- a) (d :: TYPE b).
+ :: forall (a :: GHC.Types.RuntimeRep) (b :: GHC.Types.RuntimeRep) (c :: TYPE
+ a) (d :: TYPE b).
c -> d -> (# c, d #)
diff --git a/testsuite/tests/ghci/scripts/T7939.stdout b/testsuite/tests/ghci/scripts/T7939.stdout
index 1e6c5b7548..2b2c8b73ad 100644
--- a/testsuite/tests/ghci/scripts/T7939.stdout
+++ b/testsuite/tests/ghci/scripts/T7939.stdout
@@ -1,32 +1,25 @@
class Foo (a :: k) where
- type family Bar (a :: k) b
- Kind: forall k1. k1 -> * -> *
+ type family Bar (a :: k) b :: *
-- Defined at T7939.hs:6:4
Bar :: k -> * -> *
-type family F a
- Kind: * -> *
- -- Defined at T7939.hs:8:1
+type family F a :: * -- Defined at T7939.hs:8:1
type instance F Int = Bool -- Defined at T7939.hs:9:15
F :: * -> *
-type family G a
- Kind: * -> *
+type family G a :: *
where G Int = Bool
-- Defined at T7939.hs:11:1
G :: * -> *
-type family H (a :: Bool)
- Kind: Bool -> Bool
+type family H (a :: Bool) :: Bool
where H 'False = 'True
-- Defined at T7939.hs:14:1
H :: Bool -> Bool
-type family J (a :: [k])
- Kind: forall k1. [k1] -> Bool
+type family J (a :: [k]) :: Bool
where
[k] J k '[] = 'False
[k, (h :: k), (t :: [k])] J k (h : t) = 'True
-- Defined at T7939.hs:17:1
J :: [k] -> Bool
-type family K (a1 :: [a])
- Kind: forall a2. [a2] -> Maybe a2
+type family K (a1 :: [a]) :: Maybe a
where
[a] K a '[] = 'Nothing
[a, (h :: a), (t :: [a])] K a (h : t) = 'Just h
diff --git a/testsuite/tests/ghci/scripts/T8535.stdout b/testsuite/tests/ghci/scripts/T8535.stdout
index 2f35e23a77..6eb08cdfe4 100644
--- a/testsuite/tests/ghci/scripts/T8535.stdout
+++ b/testsuite/tests/ghci/scripts/T8535.stdout
@@ -1,4 +1,4 @@
-data (->) a b -- Defined in ‘GHC.Prim’
+data (->) t1 t2 -- Defined in ‘GHC.Prim’
infixr 0 `(->)`
instance Monad ((->) r) -- Defined in ‘GHC.Base’
instance Functor ((->) r) -- Defined in ‘GHC.Base’
diff --git a/testsuite/tests/ghci/scripts/T9181.stdout b/testsuite/tests/ghci/scripts/T9181.stdout
index 3482d54ba4..43bbbacd74 100644
--- a/testsuite/tests/ghci/scripts/T9181.stdout
+++ b/testsuite/tests/ghci/scripts/T9181.stdout
@@ -1,23 +1,23 @@
type family (GHC.TypeLits.*) (a :: GHC.Types.Nat)
(b :: GHC.Types.Nat)
- Kind: GHC.Types.Nat -> GHC.Types.Nat -> GHC.Types.Nat
+ :: GHC.Types.Nat
type family (GHC.TypeLits.+) (a :: GHC.Types.Nat)
(b :: GHC.Types.Nat)
- Kind: GHC.Types.Nat -> GHC.Types.Nat -> GHC.Types.Nat
+ :: GHC.Types.Nat
type family (GHC.TypeLits.-) (a :: GHC.Types.Nat)
(b :: GHC.Types.Nat)
- Kind: GHC.Types.Nat -> GHC.Types.Nat -> GHC.Types.Nat
+ :: GHC.Types.Nat
type (GHC.TypeLits.<=) (x :: GHC.Types.Nat) (y :: GHC.Types.Nat) =
- (x GHC.TypeLits.<=? y) ~ 'True
+ (x GHC.TypeLits.<=? y) ~ 'True :: Constraint
type family (GHC.TypeLits.<=?) (a :: GHC.Types.Nat)
(b :: GHC.Types.Nat)
- Kind: GHC.Types.Nat -> GHC.Types.Nat -> Bool
+ :: Bool
type family GHC.TypeLits.CmpNat (a :: GHC.Types.Nat)
(b :: GHC.Types.Nat)
- Kind: GHC.Types.Nat -> GHC.Types.Nat -> Ordering
+ :: Ordering
type family GHC.TypeLits.CmpSymbol (a :: GHC.Types.Symbol)
(b :: GHC.Types.Symbol)
- Kind: GHC.Types.Symbol -> GHC.Types.Symbol -> Ordering
+ :: Ordering
data GHC.TypeLits.ErrorMessage where
GHC.TypeLits.Text :: GHC.Types.Symbol -> GHC.TypeLits.ErrorMessage
GHC.TypeLits.ShowType :: t -> GHC.TypeLits.ErrorMessage
@@ -38,10 +38,10 @@ data GHC.TypeLits.SomeSymbol where
GHC.TypeLits.SomeSymbol :: GHC.TypeLits.KnownSymbol n =>
(Data.Proxy.Proxy n) -> GHC.TypeLits.SomeSymbol
type family GHC.TypeLits.TypeError (a :: GHC.TypeLits.ErrorMessage)
- Kind: forall b1. GHC.TypeLits.ErrorMessage -> b1
+ :: b
type family (GHC.TypeLits.^) (a :: GHC.Types.Nat)
(b :: GHC.Types.Nat)
- Kind: GHC.Types.Nat -> GHC.Types.Nat -> GHC.Types.Nat
+ :: GHC.Types.Nat
GHC.TypeLits.natVal ::
GHC.TypeLits.KnownNat n => proxy n -> Integer
GHC.TypeLits.natVal' ::
diff --git a/testsuite/tests/ghci/scripts/ghci020.stdout b/testsuite/tests/ghci/scripts/ghci020.stdout
index 2f35e23a77..6eb08cdfe4 100644
--- a/testsuite/tests/ghci/scripts/ghci020.stdout
+++ b/testsuite/tests/ghci/scripts/ghci020.stdout
@@ -1,4 +1,4 @@
-data (->) a b -- Defined in ‘GHC.Prim’
+data (->) t1 t2 -- Defined in ‘GHC.Prim’
infixr 0 `(->)`
instance Monad ((->) r) -- Defined in ‘GHC.Base’
instance Functor ((->) r) -- Defined in ‘GHC.Base’
diff --git a/testsuite/tests/ghci/should_run/T10145.stdout b/testsuite/tests/ghci/should_run/T10145.stdout
index 2f35e23a77..6eb08cdfe4 100644
--- a/testsuite/tests/ghci/should_run/T10145.stdout
+++ b/testsuite/tests/ghci/should_run/T10145.stdout
@@ -1,4 +1,4 @@
-data (->) a b -- Defined in ‘GHC.Prim’
+data (->) t1 t2 -- Defined in ‘GHC.Prim’
infixr 0 `(->)`
instance Monad ((->) r) -- Defined in ‘GHC.Base’
instance Functor ((->) r) -- Defined in ‘GHC.Base’
diff --git a/testsuite/tests/indexed-types/should_compile/T3017.stderr b/testsuite/tests/indexed-types/should_compile/T3017.stderr
index 68214e946e..3000395aa2 100644
--- a/testsuite/tests/indexed-types/should_compile/T3017.stderr
+++ b/testsuite/tests/indexed-types/should_compile/T3017.stderr
@@ -7,13 +7,11 @@ TYPE SIGNATURES
forall c t t1. (Elem c ~ (t, t1), Coll c, Num t1, Num t) => c -> c
TYPE CONSTRUCTORS
class Coll c where
- type family Elem c open
- Kind: * -> *
+ type family Elem c :: * open
empty :: c
insert :: Elem c -> c -> c
{-# MINIMAL empty, insert #-}
data ListColl a = L [a]
- Kind: * -> *
COERCION AXIOMS
axiom Foo.D:R:ElemListColl ::
Elem (ListColl a) = a -- Defined at T3017.hs:13:9
diff --git a/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr b/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr
index 04eedb1eaf..ba1f46ef47 100644
--- a/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr
+++ b/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr
@@ -1,40 +1,31 @@
-ClosedFam3.hs-boot:5:1:
+ClosedFam3.hs-boot:5:1: error:
Type constructor ‘Foo’ has conflicting definitions in the module
and its hs-boot file
- Main module: type family Foo a
- Kind: * -> *
+ Main module: type family Foo a :: *
where
- Foo Int = Bool
- Foo Double = Char
- Boot file: type family Foo a
- Kind: * -> *
- where
- Foo Int = Bool
+ Foo Int = Bool
+ Foo Double = Char
+ Boot file: type family Foo a :: *
+ where Foo Int = Bool
-ClosedFam3.hs-boot:8:1:
+ClosedFam3.hs-boot:8:1: error:
Type constructor ‘Bar’ has conflicting definitions in the module
and its hs-boot file
- Main module: type family Bar a
- Kind: * -> *
+ Main module: type family Bar a :: *
where
- Bar Int = Bool
- Bar Double = Double
- Boot file: type family Bar a
- Kind: * -> *
+ Bar Int = Bool
+ Bar Double = Double
+ Boot file: type family Bar a :: *
where
- Bar Int = Bool
- Bar Double = Char
+ Bar Int = Bool
+ Bar Double = Char
-ClosedFam3.hs-boot:12:1:
+ClosedFam3.hs-boot:12:1: error:
Type constructor ‘Baz’ has conflicting definitions in the module
and its hs-boot file
- Main module: type family Baz a
- Kind: * -> *
- where
- Baz Int = Bool
- Boot file: type family Baz (a :: k)
- Kind: forall k1. k1 -> *
- where
- Baz * Int = Bool
+ Main module: type family Baz a :: *
+ where Baz Int = Bool
+ Boot file: type family Baz (a :: k) :: *
+ where Baz * Int = Bool
The types have different kinds
diff --git a/testsuite/tests/indexed-types/should_fail/Overlap4.stderr b/testsuite/tests/indexed-types/should_fail/Overlap4.stderr
index d64036c4bc..937a18d861 100644
--- a/testsuite/tests/indexed-types/should_fail/Overlap4.stderr
+++ b/testsuite/tests/indexed-types/should_fail/Overlap4.stderr
@@ -1,5 +1,6 @@
-Overlap4.hs:7:3:
- Number of parameters must match family declaration; expected 2
- In the equations for closed type family ‘F’
- In the type family declaration for ‘F’
+Overlap4.hs:7:12: error:
+ • Expecting one more argument to ‘Maybe’
+ Expected a type, but ‘Maybe’ has kind ‘* -> *’
+ • In the type ‘Maybe’
+ In the type family declaration for ‘F’
diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr
index 8637eaa892..b0c91af91a 100644
--- a/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr
+++ b/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr
@@ -1,5 +1,4 @@
SimpleFail1a.hs:4:1: error:
- • Expecting one more argument to ‘T1 Int’
- Expected a type, but ‘T1 Int’ has kind ‘* -> *’
+ • Number of parameters must match family declaration; expected 2
• In the data instance declaration for ‘T1’
diff --git a/testsuite/tests/indexed-types/should_fail/TyFamArity1.stderr b/testsuite/tests/indexed-types/should_fail/TyFamArity1.stderr
index b99c8d9934..8b3d5f5910 100644
--- a/testsuite/tests/indexed-types/should_fail/TyFamArity1.stderr
+++ b/testsuite/tests/indexed-types/should_fail/TyFamArity1.stderr
@@ -1,4 +1,6 @@
-TyFamArity1.hs:4:15:
- Number of parameters must match family declaration; expected 2
- In the type instance declaration for ‘T’
+TyFamArity1.hs:4:23: error:
+ • Expecting one more argument to ‘IO’
+ Expected a type, but ‘IO’ has kind ‘* -> *’
+ • In the type ‘IO’
+ In the type instance declaration for ‘T’
diff --git a/testsuite/tests/indexed-types/should_fail/TyFamArity2.stderr b/testsuite/tests/indexed-types/should_fail/TyFamArity2.stderr
index 28107aaed6..778d8ab9f4 100644
--- a/testsuite/tests/indexed-types/should_fail/TyFamArity2.stderr
+++ b/testsuite/tests/indexed-types/should_fail/TyFamArity2.stderr
@@ -1,4 +1,11 @@
-TyFamArity2.hs:4:15:
- Number of parameters must match family declaration; expected 1
- In the type instance declaration for ‘T’
+TyFamArity2.hs:4:15: error:
+ • Too many parameters to T:
+ Float is unexpected;
+ expected only one parameter
+ • In the type instance declaration for ‘T’
+
+TyFamArity2.hs:4:29: error:
+ • Expected kind ‘* -> *’, but ‘Char’ has kind ‘*’
+ • In the type ‘Char’
+ In the type instance declaration for ‘T’
diff --git a/testsuite/tests/indexed-types/should_run/T11465a.hs b/testsuite/tests/indexed-types/should_run/T11465a.hs
index 41fc19738c..d3626cf198 100644
--- a/testsuite/tests/indexed-types/should_run/T11465a.hs
+++ b/testsuite/tests/indexed-types/should_run/T11465a.hs
@@ -7,7 +7,7 @@
import GHC.Exts
import GHC.Types
-class BoxIt (a :: TYPE 'Unlifted) where
+class BoxIt (a :: TYPE 'WordRep) where
type Boxed a :: *
boxed :: a -> Boxed a
diff --git a/testsuite/tests/partial-sigs/should_compile/ADT.stderr b/testsuite/tests/partial-sigs/should_compile/ADT.stderr
index 0da9e2284a..10658a2d4a 100644
--- a/testsuite/tests/partial-sigs/should_compile/ADT.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ADT.stderr
@@ -3,7 +3,6 @@ TYPE SIGNATURES
bar :: Int -> Foo Bool () Int
TYPE CONSTRUCTORS
data Foo x y z = Foo x y z
- Kind: * -> * -> * -> *
COERCION AXIOMS
Dependent modules: []
Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0,
diff --git a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr
index 6a2ac84f6c..7b12afc302 100644
--- a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr
@@ -12,7 +12,6 @@ TYPE SIGNATURES
foo :: Sing 'A
TYPE CONSTRUCTORS
data MyKind = A | B
- Kind: *
data family Sing (a :: k)
COERCION AXIOMS
axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 ::
diff --git a/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr b/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr
index cf6a223c45..29619d15ed 100644
--- a/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/Meltdown.stderr
@@ -6,7 +6,6 @@ TYPE SIGNATURES
TYPE CONSTRUCTORS
type role NukeMonad phantom phantom phantom
data NukeMonad a b c
- Kind: * -> * -> * -> *
COERCION AXIOMS
INSTANCES
instance Functor (NukeMonad a b) -- Defined at Meltdown.hs:8:10
@@ -15,4 +14,4 @@ INSTANCES
instance Monad (NukeMonad a b) -- Defined at Meltdown.hs:15:10
Dependent modules: []
Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0,
- integer-gmp-1.0.0.0]
+ integer-gmp-1.0.0.1]
diff --git a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr
index b335118ed8..5b8982ba16 100644
--- a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr
@@ -11,7 +11,6 @@ TYPE SIGNATURES
NamedWildcardInDataFamilyInstanceLHS.R:SingMyKind_a _a
TYPE CONSTRUCTORS
data MyKind = A | B
- Kind: *
data family Sing (a :: k)
COERCION AXIOMS
axiom NamedWildcardInDataFamilyInstanceLHS.D:R:SingMyKind_a0 ::
diff --git a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr
index c39ff6f254..bba0917ec3 100644
--- a/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr
@@ -1,7 +1,6 @@
TYPE SIGNATURES
TYPE CONSTRUCTORS
- type family F a
- Kind: * -> *
+ type family F a :: *
where
[_t] F _t = Int
axiom NamedWildcardInTypeFamilyInstanceLHS.D:R:F
diff --git a/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr b/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr
index be635e620d..5b94077eb0 100644
--- a/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/SkipMany.stderr
@@ -7,7 +7,6 @@ TYPE SIGNATURES
forall tok st a. GenParser tok st a -> GenParser tok st ()
TYPE CONSTRUCTORS
data GenParser tok st a = GenParser tok st a
- Kind: * -> * -> * -> *
COERCION AXIOMS
Dependent modules: []
Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0,
diff --git a/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr
index 0800286480..78377fb81d 100644
--- a/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr
@@ -1,8 +1,7 @@
TYPE SIGNATURES
foo :: F Int Char -> Int
TYPE CONSTRUCTORS
- type family F a b open
- Kind: * -> * -> *
+ type family F a b :: * open
COERCION AXIOMS
axiom TypeFamilyInstanceLHS.D:R:FBool_ ::
F Bool _ = Bool -- Defined at TypeFamilyInstanceLHS.hs:6:15
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 776e062e7e..61ac9b2076 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -747,8 +747,9 @@ test('T9233',
test('T10370',
[ only_ways(['optasm']),
compiler_stats_num_field('max_bytes_used', # Note [residency]
- [(wordsize(64), 19548720, 15),
+ [(wordsize(64), 22823976, 15),
# 2015-10-22 19548720
+ # 2016-02-24 22823976 Changing Levity to RuntimeRep; not sure why this regresses though, even after some analysis
(wordsize(32), 11371496, 15),
# 2015-10-22 11371496
]),
diff --git a/testsuite/tests/polykinds/T11399.stderr b/testsuite/tests/polykinds/T11399.stderr
index 31ccdf80b5..5e09870088 100644
--- a/testsuite/tests/polykinds/T11399.stderr
+++ b/testsuite/tests/polykinds/T11399.stderr
@@ -1,9 +1,9 @@
T11399.hs:7:32: error:
- • Couldn't match kind ‘*’ with ‘GHC.Types.Levity’
+ • Couldn't match kind ‘*’ with ‘GHC.Types.RuntimeRep’
When matching kinds
k :: * -> *
- TYPE :: GHC.Types.Levity -> *
+ TYPE :: GHC.Types.RuntimeRep -> *
Expected kind ‘* -> *’, but ‘UhOh k’ has kind ‘k * -> *’
• In the first argument of ‘Functor’, namely ‘UhOh k’
In the instance declaration for ‘Functor (UhOh k)’
diff --git a/testsuite/tests/polykinds/T7328.stderr b/testsuite/tests/polykinds/T7328.stderr
index 31b425f644..58e883e142 100644
--- a/testsuite/tests/polykinds/T7328.stderr
+++ b/testsuite/tests/polykinds/T7328.stderr
@@ -1,6 +1,6 @@
T7328.hs:8:34: error:
- • Occurs check: cannot construct the infinite kind: k10 ~ k0 -> k10
+ • Occurs check: cannot construct the infinite kind: k0 ~ k1 -> k0
• In the first argument of ‘Foo’, namely ‘f’
In the first argument of ‘Proxy’, namely ‘Foo f’
In the type signature:
diff --git a/testsuite/tests/polykinds/TidyClassKinds.stderr b/testsuite/tests/polykinds/TidyClassKinds.stderr
index 69ca49c188..5cbea8b417 100644
--- a/testsuite/tests/polykinds/TidyClassKinds.stderr
+++ b/testsuite/tests/polykinds/TidyClassKinds.stderr
@@ -1,7 +1,7 @@
TidyClassKinds.hs:12:10: error:
• Illegal instance declaration for
- ‘Poly (k1 -> *) (k1 -> *) (ProxySyn k1) (ProxySyn k1)’
+ ‘Poly (k -> *) (k -> *) (ProxySyn k) (ProxySyn k)’
(All instance types must be of the form (T t1 ... tn)
where T is not a synonym.
Use TypeSynonymInstances if you want to disable this.)
diff --git a/testsuite/tests/roles/should_compile/Roles1.stderr b/testsuite/tests/roles/should_compile/Roles1.stderr
index 6ea24f009b..fe0658b56c 100644
--- a/testsuite/tests/roles/should_compile/Roles1.stderr
+++ b/testsuite/tests/roles/should_compile/Roles1.stderr
@@ -9,23 +9,16 @@ TYPE SIGNATURES
TYPE CONSTRUCTORS
type role T1 nominal
data T1 a = K1 a
- Kind: * -> *
data T2 a = K2 a
- Kind: * -> *
type role T3 phantom
data T3 (a :: k) = K3
- Kind: forall k1. k1 -> *
type role T4 nominal nominal
data T4 (a :: * -> *) b = K4 (a b)
- Kind: (* -> *) -> * -> *
data T5 a = K5 a
- Kind: * -> *
type role T6 phantom
data T6 (a :: k) = K6
- Kind: forall {k1}. k1 -> *
type role T7 phantom representational
data T7 (a :: k) b = K7 b
- Kind: forall {k1}. k1 -> * -> *
COERCION AXIOMS
Dependent modules: []
Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0,
diff --git a/testsuite/tests/roles/should_compile/Roles2.stderr b/testsuite/tests/roles/should_compile/Roles2.stderr
index 7c075b9bce..65ba748863 100644
--- a/testsuite/tests/roles/should_compile/Roles2.stderr
+++ b/testsuite/tests/roles/should_compile/Roles2.stderr
@@ -3,10 +3,8 @@ TYPE SIGNATURES
Roles2.K2 :: forall a. FunPtr a -> T2 a
TYPE CONSTRUCTORS
data T1 a = K1 (IO a)
- Kind: * -> *
type role T2 phantom
data T2 a = K2 (FunPtr a)
- Kind: * -> *
COERCION AXIOMS
Dependent modules: []
Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0,
diff --git a/testsuite/tests/roles/should_compile/Roles3.stderr b/testsuite/tests/roles/should_compile/Roles3.stderr
index 544e497c2d..ca496ed042 100644
--- a/testsuite/tests/roles/should_compile/Roles3.stderr
+++ b/testsuite/tests/roles/should_compile/Roles3.stderr
@@ -11,15 +11,13 @@ TYPE CONSTRUCTORS
meth2 :: a ~ b => a -> b
{-# MINIMAL meth2 #-}
class C3 a b where
- type family F3 b open
- Kind: * -> *
+ type family F3 b :: * open
meth3 :: a -> F3 b -> F3 b
{-# MINIMAL meth3 #-}
class C4 a b where
meth4 :: a -> F4 b -> F4 b
{-# MINIMAL meth4 #-}
- type family F4 a open
- Kind: * -> *
+ type family F4 a :: * open
type Syn1 a = F4 a
type Syn2 a = [a]
COERCION AXIOMS
diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr
index 91b58a1ba6..9b4e2d911c 100644
--- a/testsuite/tests/roles/should_compile/T8958.stderr
+++ b/testsuite/tests/roles/should_compile/T8958.stderr
@@ -6,7 +6,6 @@ TYPE SIGNATURES
TYPE CONSTRUCTORS
type role Map nominal representational
newtype (Nominal k, Representational v) => Map k v = MkMap [(k, v)]
- Kind: * -> * -> *
class Nominal a
type role Representational representational
class Representational a
diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr
index 996890ff94..3f6ae06a20 100644
--- a/testsuite/tests/simplCore/should_compile/T9400.stderr
+++ b/testsuite/tests/simplCore/should_compile/T9400.stderr
@@ -46,7 +46,7 @@ main =
@ ()
(putStrLn (unpackCString# "efg"#))
(Control.Exception.Base.patError
- @ 'Lifted @ (IO ()) "T9400.hs:(17,5)-(18,29)|case"#))))
+ @ 'PtrRepLifted @ (IO ()) "T9400.hs:(17,5)-(18,29)|case"#))))
diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
index 41824247d7..061a81fee0 100644
--- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr
+++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
@@ -35,7 +35,7 @@ Roman.foo3 :: Int
[GblId, Str=DmdType x]
Roman.foo3 =
Control.Exception.Base.patError
- @ 'GHC.Types.Lifted
+ @ 'GHC.Types.PtrRepLifted
@ Int
"spec-inline.hs:(19,5)-(29,25)|function go"#
diff --git a/testsuite/tests/th/TH_Roles2.stderr b/testsuite/tests/th/TH_Roles2.stderr
index 174affe833..afcac7c6b7 100644
--- a/testsuite/tests/th/TH_Roles2.stderr
+++ b/testsuite/tests/th/TH_Roles2.stderr
@@ -2,12 +2,11 @@ TYPE SIGNATURES
TYPE CONSTRUCTORS
type role T representational
data T (a :: k)
- Kind: forall k1. k1 -> *
COERCION AXIOMS
Dependent modules: []
-Dependent packages: [array-0.5.1.0, base-4.9.0.0, binary-0.8.0.0,
+Dependent packages: [array-0.5.1.0, base-4.9.0.0, binary-0.8.2.0,
bytestring-0.10.7.0, containers-0.5.7.1, deepseq-1.4.2.0,
- ghc-boot-0.0.0.0, ghc-prim-0.5.0.0, integer-gmp-1.0.0.0,
+ ghc-boot-8.1, ghc-prim-0.5.0.0, integer-gmp-1.0.0.1,
pretty-1.1.3.2, template-haskell-2.11.0.0]
==================== Typechecker ====================
diff --git a/testsuite/tests/typecheck/should_compile/tc231.stderr b/testsuite/tests/typecheck/should_compile/tc231.stderr
index 8c35af42cb..dd5624849a 100644
--- a/testsuite/tests/typecheck/should_compile/tc231.stderr
+++ b/testsuite/tests/typecheck/should_compile/tc231.stderr
@@ -10,9 +10,7 @@ TYPE SIGNATURES
s :: forall t t1. Q t (Z [Char]) t1 -> Q t (Z [Char]) t1
TYPE CONSTRUCTORS
data Q s a chain = Node s a chain
- Kind: * -> * -> * -> *
data Z a = Z a
- Kind: * -> *
class Zork s a b | a -> b where
huh :: Q s a chain -> ST s ()
{-# MINIMAL huh #-}
diff --git a/testsuite/tests/typecheck/should_run/KindInvariant.stderr b/testsuite/tests/typecheck/should_run/KindInvariant.stderr
index 777b802415..3fe8131daf 100644
--- a/testsuite/tests/typecheck/should_run/KindInvariant.stderr
+++ b/testsuite/tests/typecheck/should_run/KindInvariant.stderr
@@ -1,5 +1,6 @@
<interactive>:1:3: error:
- • Expected kind ‘* -> *’, but ‘State#’ has kind ‘* -> #’
+ • Expected kind ‘* -> *’,
+ but ‘State#’ has kind ‘* -> TYPE 'VoidRep’
• In the first argument of ‘T’, namely ‘State#’
In the type ‘T State#’
diff --git a/testsuite/tests/typecheck/should_run/TypeOf.hs b/testsuite/tests/typecheck/should_run/TypeOf.hs
index 12184e7a1c..efd26f9640 100644
--- a/testsuite/tests/typecheck/should_run/TypeOf.hs
+++ b/testsuite/tests/typecheck/should_run/TypeOf.hs
@@ -27,8 +27,8 @@ main = do
print $ typeOf (Proxy :: Proxy [1,2,3])
print $ typeOf (Proxy :: Proxy 'EQ)
print $ typeOf (Proxy :: Proxy TYPE)
- print $ typeOf (Proxy :: Proxy (TYPE 'Lifted))
+ print $ typeOf (Proxy :: Proxy (TYPE 'PtrRepLifted))
print $ typeOf (Proxy :: Proxy *)
print $ typeOf (Proxy :: Proxy ★)
- print $ typeOf (Proxy :: Proxy 'Lifted)
+ print $ typeOf (Proxy :: Proxy 'PtrRepLifted)
print $ typeOf (Proxy :: Proxy (~~))
diff --git a/testsuite/tests/typecheck/should_run/TypeOf.stdout b/testsuite/tests/typecheck/should_run/TypeOf.stdout
index ffc2133e20..6f160f544c 100644
--- a/testsuite/tests/typecheck/should_run/TypeOf.stdout
+++ b/testsuite/tests/typecheck/should_run/TypeOf.stdout
@@ -15,9 +15,9 @@ Proxy Symbol "hello world"
Proxy Nat 1
Proxy [Nat] (': Nat 1 (': Nat 2 (': Nat 3 '[])))
Proxy Ordering 'EQ
-Proxy (Levity -> Constraint) TYPE
+Proxy (RuntimeRep -> Constraint) TYPE
Proxy Constraint Constraint
Proxy Constraint Constraint
Proxy Constraint Constraint
-Proxy Levity 'Lifted
+Proxy RuntimeRep 'PtrRepLifted
Proxy (Constraint -> Constraint -> Constraint) ~~
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index e6af0f200e..294591444d 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -66,7 +66,7 @@ desugarVectorSpec i = case vecOptions i of
| drop len s == suf = Just (take len s)
| otherwise = Nothing
where
- len = length s - length suf
+ len = length s - length suf
lowerHead s = toLower (head s) : tail s
@@ -121,37 +121,37 @@ main = getArgs >>= \args ->
-> seq (sanityTop p_o_specs) (
case head args of
- "--data-decl"
+ "--data-decl"
-> putStr (gen_data_decl p_o_specs)
- "--has-side-effects"
- -> putStr (gen_switch_from_attribs
- "has_side_effects"
+ "--has-side-effects"
+ -> putStr (gen_switch_from_attribs
+ "has_side_effects"
"primOpHasSideEffects" p_o_specs)
- "--out-of-line"
- -> putStr (gen_switch_from_attribs
- "out_of_line"
+ "--out-of-line"
+ -> putStr (gen_switch_from_attribs
+ "out_of_line"
"primOpOutOfLine" p_o_specs)
- "--commutable"
- -> putStr (gen_switch_from_attribs
- "commutable"
+ "--commutable"
+ -> putStr (gen_switch_from_attribs
+ "commutable"
"commutableOp" p_o_specs)
"--code-size"
- -> putStr (gen_switch_from_attribs
+ -> putStr (gen_switch_from_attribs
"code_size"
"primOpCodeSize" p_o_specs)
"--can-fail"
-> putStr (gen_switch_from_attribs
- "can_fail"
+ "can_fail"
"primOpCanFail" p_o_specs)
- "--strictness"
- -> putStr (gen_switch_from_attribs
- "strictness"
+ "--strictness"
+ -> putStr (gen_switch_from_attribs
+ "strictness"
"primOpStrictness" p_o_specs)
"--fixity"
@@ -159,31 +159,31 @@ main = getArgs >>= \args ->
"fixity"
"primOpFixity" p_o_specs)
- "--primop-primop-info"
+ "--primop-primop-info"
-> putStr (gen_primop_info p_o_specs)
- "--primop-tag"
+ "--primop-tag"
-> putStr (gen_primop_tag p_o_specs)
- "--primop-list"
+ "--primop-list"
-> putStr (gen_primop_list p_o_specs)
- "--primop-vector-uniques"
+ "--primop-vector-uniques"
-> putStr (gen_primop_vector_uniques p_o_specs)
- "--primop-vector-tys"
+ "--primop-vector-tys"
-> putStr (gen_primop_vector_tys p_o_specs)
- "--primop-vector-tys-exports"
+ "--primop-vector-tys-exports"
-> putStr (gen_primop_vector_tys_exports p_o_specs)
- "--primop-vector-tycons"
+ "--primop-vector-tycons"
-> putStr (gen_primop_vector_tycons p_o_specs)
- "--make-haskell-wrappers"
+ "--make-haskell-wrappers"
-> putStr (gen_wrappers p_o_specs)
-
- "--make-haskell-source"
+
+ "--make-haskell-source"
-> putStr (gen_hs_source p_o_specs)
"--make-latex-doc"
@@ -193,7 +193,7 @@ main = getArgs >>= \args ->
)
known_args :: [String]
-known_args
+known_args
= [ "--data-decl",
"--has-side-effects",
"--out-of-line",
@@ -391,12 +391,12 @@ pprTy = pty
gen_latex_doc :: Info -> String
gen_latex_doc (Info defaults entries)
- = "\\primopdefaults{"
+ = "\\primopdefaults{"
++ mk_options defaults
++ "}\n"
++ (concat (map mk_entry entries))
where mk_entry (PrimOpSpec {cons=constr,name=n,ty=t,cat=c,desc=d,opts=o}) =
- "\\primopdesc{"
+ "\\primopdesc{"
++ latex_encode constr ++ "}{"
++ latex_encode n ++ "}{"
++ latex_encode (zencode n) ++ "}{"
@@ -409,7 +409,7 @@ gen_latex_doc (Info defaults entries)
mk_entry (PrimVecOpSpec {}) =
""
mk_entry (Section {title=ti,desc=d}) =
- "\\primopsection{"
+ "\\primopsection{"
++ latex_encode ti ++ "}{"
++ d ++ "}\n"
mk_entry (PrimTypeSpec {ty=t,desc=d,opts=o}) =
@@ -438,7 +438,7 @@ gen_latex_doc (Info defaults entries)
pbty t = paty t
paty (TyVar tv) = tv
paty t = "(" ++ pty t ++ ")"
-
+
mk_core_ty typ = foralls ++ (pty typ)
where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
@@ -453,7 +453,7 @@ gen_latex_doc (Info defaults entries)
utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)"
foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars)
tvars = tvars_of typ
- tbinds [] = ". "
+ tbinds [] = ". "
tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs)
tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs)
tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2
@@ -461,7 +461,7 @@ gen_latex_doc (Info defaults entries)
tvars_of (TyApp _ ts) = foldl union [] (map tvars_of ts)
tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts)
tvars_of (TyVar tv) = [tv]
-
+
mk_options o =
"\\primoptions{"
++ mk_has_side_effects o ++ "}{"
@@ -488,12 +488,12 @@ gen_latex_doc (Info defaults entries)
Just (OptionFixity _) -> error "Fixity value for boolean option"
Just (OptionVector _) -> error "vector template for boolean option"
Nothing -> ""
-
- mk_strictness o =
+
+ mk_strictness o =
case lookup_attrib "strictness" o of
Just (OptionString _ s) -> s -- for now
Just _ -> error "Wrong value for strictness"
- Nothing -> ""
+ Nothing -> ""
mk_fixity o = case lookup_attrib "fixity" o of
Just (OptionFixity (Just (Fixity _ i d)))
@@ -514,19 +514,19 @@ gen_latex_doc (Info defaults entries)
(n, ')' : _) -> Just ('Z' : shows (n+1) "T")
_ -> Nothing
maybe_tuple _ = Nothing
-
+
count_commas :: Int -> String -> (Int, String)
count_commas n (',' : cs) = count_commas (n+1) cs
count_commas n cs = (n,cs)
-
+
unencodedChar :: Char -> Bool -- True for chars that don't need encoding
unencodedChar 'Z' = False
unencodedChar 'z' = False
unencodedChar c = isAlphaNum c
-
+
encode_ch :: Char -> String
encode_ch c | unencodedChar c = [c] -- Common case first
-
+
-- Constructors
encode_ch '(' = "ZL" -- Needed for things like (,), and (->)
encode_ch ')' = "ZR" -- For symmetry with (
@@ -534,7 +534,7 @@ gen_latex_doc (Info defaults entries)
encode_ch ']' = "ZN"
encode_ch ':' = "ZC"
encode_ch 'Z' = "ZZ"
-
+
-- Variables
encode_ch 'z' = "zz"
encode_ch '&' = "za"
@@ -556,7 +556,7 @@ gen_latex_doc (Info defaults entries)
encode_ch '_' = "zu"
encode_ch '%' = "zv"
encode_ch c = 'z' : shows (ord c) "U"
-
+
latex_encode [] = []
latex_encode (c:cs) | c `elem` "#$%&_^{}" = "\\" ++ c:(latex_encode cs)
latex_encode ('~':cs) = "\\verb!~!" ++ (latex_encode cs)
@@ -568,8 +568,8 @@ gen_wrappers (Info _ entries)
= "{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-}\n"
-- Dependencies on Prelude must be explicit in libraries/base, but we
-- don't need the Prelude here so we add NoImplicitPrelude.
- ++ "module GHC.PrimopWrappers where\n"
- ++ "import qualified GHC.Prim\n"
+ ++ "module GHC.PrimopWrappers where\n"
+ ++ "import qualified GHC.Prim\n"
++ "import GHC.Tuple ()\n"
++ "import GHC.Prim (" ++ types ++ ")\n"
++ unlines (concatMap f specs)
@@ -591,7 +591,7 @@ gen_wrappers (Info _ entries)
| otherwise = "(" ++ nm ++ ")"
dodgy spec
- = name spec `elem`
+ = name spec `elem`
[-- tagToEnum# is really magical, and can't have
-- a wrapper since its implementation depends on
-- the type of its result
@@ -610,7 +610,7 @@ gen_primop_list (Info _ entries)
[ " [" ++ cons first ]
++
map (\p -> " , " ++ cons p) rest
- ++
+ ++
[ " ]" ]
) where (first:rest) = concatMap desugarVectorSpec (filter is_primop entries)
@@ -699,7 +699,7 @@ gen_data_decl (Info _ entries) =
++ unlines (map (" | "++) (tail conss))
where
conss = map genCons (filter is_primop entries)
-
+
genCons :: Entry -> String
genCons entry =
case vecOptions entry of
@@ -728,7 +728,7 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
in
case defv of
Nothing -> error ("gen_switch_from: " ++ attrib_name)
- Just xx
+ Just xx
-> unlines alternatives
++ fn_name ++ " _ = " ++ getAltRhs xx ++ "\n"
@@ -750,9 +750,9 @@ mkPOI_LHS_text i
mkPOI_RHS_text :: Entry -> String
mkPOI_RHS_text i
= case cat i of
- Compare
+ Compare
-> case ty i of
- TyF t1 (TyF _ _)
+ TyF t1 (TyF _ _)
-> "mkCompare " ++ sl_name i ++ ppType t1
_ -> error "Type error in comparison op"
Monadic
@@ -769,7 +769,7 @@ mkPOI_RHS_text i
-> let (argTys, resTy) = flatTys (ty i)
tvs = nub (tvsIn (ty i))
in
- "mkGenPrimOp " ++ sl_name i ++ " "
+ "mkGenPrimOp " ++ sl_name i ++ " "
++ listify (map ppTyVar tvs) ++ " "
++ listify (map ppType argTys) ++ " "
++ "(" ++ ppType resTy ++ ")"
@@ -782,7 +782,7 @@ ppTyVar "a" = "alphaTyVar"
ppTyVar "b" = "betaTyVar"
ppTyVar "c" = "gammaTyVar"
ppTyVar "s" = "deltaTyVar"
-ppTyVar "o" = "levity1TyVar, openAlphaTyVar"
+ppTyVar "o" = "runtimeRep1TyVar, openAlphaTyVar"
ppTyVar _ = error "Unknown type var"
ppType :: Ty -> String
@@ -813,14 +813,14 @@ ppType (TyVar "s") = "deltaTy"
ppType (TyVar "o") = "openAlphaTy"
ppType (TyApp (TyCon "State#") [x]) = "mkStatePrimTy " ++ ppType x
-ppType (TyApp (TyCon "MutVar#") [x,y]) = "mkMutVarPrimTy " ++ ppType x
+ppType (TyApp (TyCon "MutVar#") [x,y]) = "mkMutVarPrimTy " ++ ppType x
++ " " ++ ppType y
ppType (TyApp (TyCon "MutableArray#") [x,y]) = "mkMutableArrayPrimTy " ++ ppType x
++ " " ++ ppType y
ppType (TyApp (TyCon "MutableArrayArray#") [x]) = "mkMutableArrayArrayPrimTy " ++ ppType x
ppType (TyApp (TyCon "SmallMutableArray#") [x,y]) = "mkSmallMutableArrayPrimTy " ++ ppType x
++ " " ++ ppType y
-ppType (TyApp (TyCon "MutableByteArray#") [x]) = "mkMutableByteArrayPrimTy "
+ppType (TyApp (TyCon "MutableByteArray#") [x]) = "mkMutableByteArrayPrimTy "
++ ppType x
ppType (TyApp (TyCon "Array#") [x]) = "mkArrayPrimTy " ++ ppType x
ppType (TyApp (TyCon "ArrayArray#") []) = "mkArrayArrayPrimTy"
@@ -831,14 +831,14 @@ ppType (TyApp (TyCon "Weak#") [x]) = "mkWeakPrimTy " ++ ppType x
ppType (TyApp (TyCon "StablePtr#") [x]) = "mkStablePtrPrimTy " ++ ppType x
ppType (TyApp (TyCon "StableName#") [x]) = "mkStableNamePrimTy " ++ ppType x
-ppType (TyApp (TyCon "MVar#") [x,y]) = "mkMVarPrimTy " ++ ppType x
+ppType (TyApp (TyCon "MVar#") [x,y]) = "mkMVarPrimTy " ++ ppType x
++ " " ++ ppType y
-ppType (TyApp (TyCon "TVar#") [x,y]) = "mkTVarPrimTy " ++ ppType x
+ppType (TyApp (TyCon "TVar#") [x,y]) = "mkTVarPrimTy " ++ ppType x
++ " " ++ ppType y
ppType (TyApp (VecTyCon _ pptc) []) = pptc
-ppType (TyUTup ts) = "(mkTupleTy Unboxed "
+ppType (TyUTup ts) = "(mkTupleTy Unboxed "
++ listify (map ppType ts) ++ ")"
ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
diff --git a/utils/haddock b/utils/haddock
-Subproject 23f1420c64899fff2fe45a8b797e0d7e8c931c7
+Subproject ab954263a793d8ced734459d6194a5d89214b66