summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/MkId.hs2
-rw-r--r--compiler/coreSyn/MkCore.hs28
-rw-r--r--compiler/iface/IfaceType.hs4
-rw-r--r--compiler/prelude/PrelNames.hs27
-rw-r--r--compiler/prelude/TysPrim.hs29
-rw-r--r--compiler/prelude/TysWiredIn.hs74
-rw-r--r--compiler/typecheck/TcBinds.hs6
-rw-r--r--compiler/typecheck/TcExpr.hs32
-rw-r--r--compiler/typecheck/TcHsType.hs3
-rw-r--r--compiler/typecheck/TcInteract.hs8
-rw-r--r--compiler/typecheck/TcTypeNats.hs10
-rw-r--r--compiler/types/Type.hs6
-rw-r--r--compiler/types/TypeRep.hs2
13 files changed, 150 insertions, 81 deletions
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 6895677a8f..ad584a325e 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -1088,7 +1088,7 @@ proxyHashId
ty = mkForAllTys [kv, tv] (mkProxyPrimTy k t)
kv = kKiVar
k = mkTyVarTy kv
- tv:_ = tyVarList k
+ [tv] = mkTemplateTyVars [k]
t = mkTyVarTy tv
------------------------------------------------
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index 8bdee4ae5f..3c115f419c 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -717,19 +717,30 @@ errorName :: Name
errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID
eRROR_ID :: Id
-eRROR_ID = pc_bottoming_Id1 errorName errorTy
+eRROR_ID = pc_bottoming_Id2 errorName errorTy
errorTy :: Type -- See Note [Error and friends have an "open-tyvar" forall]
-errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
+errorTy = mkSigmaTy [openAlphaTyVar] []
+ (mkFunTys [ mkClassPred
+ ipClass
+ [ mkStrLitTy (fsLit "callStack")
+ , mkTyConTy callStackTyCon ]
+ , mkListTy charTy]
+ openAlphaTy)
undefinedName :: Name
undefinedName = mkWiredInIdName gHC_ERR (fsLit "undefined") undefinedKey uNDEFINED_ID
uNDEFINED_ID :: Id
-uNDEFINED_ID = pc_bottoming_Id0 undefinedName undefinedTy
+uNDEFINED_ID = pc_bottoming_Id1 undefinedName undefinedTy
undefinedTy :: Type -- See Note [Error and friends have an "open-tyvar" forall]
-undefinedTy = mkSigmaTy [openAlphaTyVar] [] openAlphaTy
+undefinedTy = mkSigmaTy [openAlphaTyVar] []
+ (mkFunTy (mkClassPred
+ ipClass
+ [ mkStrLitTy (fsLit "callStack")
+ , mkTyConTy callStackTyCon ])
+ openAlphaTy)
{-
Note [Error and friends have an "open-tyvar" forall]
@@ -773,10 +784,11 @@ pc_bottoming_Id1 name ty
strict_sig = mkClosedStrictSig [evalDmd] botRes
-- These "bottom" out, no matter what their arguments
-pc_bottoming_Id0 :: Name -> Type -> Id
--- Same but arity zero
-pc_bottoming_Id0 name ty
+pc_bottoming_Id2 :: Name -> Type -> Id
+-- Same but arity two
+pc_bottoming_Id2 name ty
= mkVanillaGlobalWithInfo name ty bottoming_info
where
bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
- strict_sig = mkClosedStrictSig [] botRes
+ `setArityInfo` 2
+ strict_sig = mkClosedStrictSig [evalDmd, evalDmd] botRes
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index 9d95b485f3..8be97dfe40 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -61,7 +61,7 @@ import Var
-- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv )
import TysWiredIn
import TysPrim
-import PrelNames( funTyConKey, ipClassName )
+import PrelNames( funTyConKey )
import Name
import BasicTypes
import Binary
@@ -636,7 +636,7 @@ pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args)
pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc
pprTyTcApp ctxt_prec tc tys dflags
- | ifaceTyConName tc == ipClassName
+ | ifaceTyConName tc == getName ipTyCon
, ITC_Type (IfaceLitTy (IfaceStrTyLit n)) (ITC_Type ty ITC_Nil) <- tys
= char '?' <> ftext n <> ptext (sLit "::") <> ppr_ty TopPrec ty
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 12a1543d44..e56307fa94 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -320,9 +320,6 @@ basicKnownKeyNames
-- Type-level naturals
knownNatClassName, knownSymbolClassName,
- -- Implicit parameters
- ipClassName,
-
-- Source locations
callStackDataConName, callStackTyConName,
srcLocDataConName,
@@ -1172,18 +1169,14 @@ knownNatClassName = clsQual gHC_TYPELITS (fsLit "KnownNat") knownNatClassNam
knownSymbolClassName :: Name
knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey
--- Implicit parameters
-ipClassName :: Name
-ipClassName = clsQual gHC_CLASSES (fsLit "IP") ipClassNameKey
-
-- Source Locations
callStackDataConName, callStackTyConName, srcLocDataConName :: Name
callStackDataConName
- = dcQual gHC_STACK (fsLit "CallStack") callStackDataConKey
+ = dcQual gHC_TYPES (fsLit "CallStack") callStackDataConKey
callStackTyConName
- = tcQual gHC_STACK (fsLit "CallStack") callStackTyConKey
+ = tcQual gHC_TYPES (fsLit "CallStack") callStackTyConKey
srcLocDataConName
- = dcQual gHC_SRCLOC (fsLit "SrcLoc") srcLocDataConKey
+ = dcQual gHC_TYPES (fsLit "SrcLoc") srcLocDataConKey
-- plugins
pLUGINS :: Module
@@ -1312,9 +1305,6 @@ knownSymbolClassNameKey = mkPreludeClassUnique 43
ghciIoClassKey :: Unique
ghciIoClassKey = mkPreludeClassUnique 44
-ipClassNameKey :: Unique
-ipClassNameKey = mkPreludeClassUnique 45
-
{-
************************************************************************
* *
@@ -1540,6 +1530,14 @@ callStackTyConKey = mkPreludeTyConUnique 182
typeRepTyConKey :: Unique
typeRepTyConKey = mkPreludeTyConUnique 183
+-- Implicit Parameters
+ipTyConKey :: Unique
+ipTyConKey = mkPreludeTyConUnique 184
+
+ipCoNameKey :: Unique
+ipCoNameKey = mkPreludeTyConUnique 185
+
+
---------------- Template Haskell -------------------
-- USES TyConUniques 200-299
-----------------------------------------------------
@@ -1615,6 +1613,9 @@ callStackDataConKey, srcLocDataConKey :: Unique
callStackDataConKey = mkPreludeDataConUnique 36
srcLocDataConKey = mkPreludeDataConUnique 37
+ipDataConKey :: Unique
+ipDataConKey = mkPreludeDataConUnique 38
+
{-
************************************************************************
* *
diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs
index d45c6880a0..5ce89ad7ef 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/prelude/TysPrim.hs
@@ -10,7 +10,8 @@
-- | This module defines TyCons that can't be expressed in Haskell.
-- They are all, therefore, wired-in TyCons. C.f module TysWiredIn
module TysPrim(
- tyVarList, alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
+ mkTemplateTyVars,
+ alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
alphaTy, betaTy, gammaTy, deltaTy,
openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars,
kKiVar,
@@ -205,18 +206,19 @@ alphaTyVars is a list of type variables for use in templates:
["a", "b", ..., "z", "t1", "t2", ... ]
-}
-tyVarList :: Kind -> [TyVar]
-tyVarList kind = [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u)
- (mkTyVarOccFS (mkFastString name))
- noSrcSpan) kind
- | u <- [2..],
- let name | c <= 'z' = [c]
- | otherwise = 't':show u
- where c = chr (u-2 + ord 'a')
- ]
+mkTemplateTyVars :: [Kind] -> [TyVar]
+mkTemplateTyVars kinds =
+ [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u)
+ (mkTyVarOccFS (mkFastString name))
+ noSrcSpan) k
+ | (k,u) <- zip kinds [2..],
+ let name | c <= 'z' = [c]
+ | otherwise = 't':show u
+ where c = chr (u-2 + ord 'a')
+ ]
alphaTyVars :: [TyVar]
-alphaTyVars = tyVarList liftedTypeKind
+alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind
betaTyVars :: [TyVar]
betaTyVars = tail alphaTyVars
@@ -234,14 +236,15 @@ alphaTy, betaTy, gammaTy, deltaTy :: Type
-- result type for "error", so that we can have (error Int# "Help")
openAlphaTyVars :: [TyVar]
openAlphaTyVar, openBetaTyVar :: TyVar
-openAlphaTyVars@(openAlphaTyVar:openBetaTyVar:_) = tyVarList openTypeKind
+openAlphaTyVars@(openAlphaTyVar:openBetaTyVar:_)
+ = mkTemplateTyVars $ repeat openTypeKind
openAlphaTy, openBetaTy :: Type
openAlphaTy = mkTyVarTy openAlphaTyVar
openBetaTy = mkTyVarTy openBetaTyVar
kKiVar :: KindVar
-kKiVar = (tyVarList superKind) !! 10
+kKiVar = (mkTemplateTyVars $ repeat superKind) !! 10
{-
************************************************************************
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index f8ee24fbe8..449377d03c 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -75,6 +75,11 @@ module TysWiredIn (
eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon,
coercibleTyCon, coercibleDataCon, coercibleClass,
+ -- * Implicit Parameters
+ ipTyCon, ipDataCon, ipClass,
+
+ callStackTyCon,
+
mkWiredInTyConName -- This is used in TcTypeNats to define the
-- built-in functions for evaluation.
) where
@@ -88,6 +93,8 @@ import PrelNames
import TysPrim
-- others:
+import CoAxiom
+import Coercion
import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
import Module ( Module )
import Type ( mkTyConApp )
@@ -160,6 +167,7 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
, coercibleTyCon
, typeNatKindCon
, typeSymbolKindCon
+ , ipTyCon
]
mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
@@ -174,6 +182,13 @@ mkWiredInDataConName built_in modu fs unique datacon
(AConLike (RealDataCon datacon)) -- Relevant DataCon
built_in
+mkWiredInCoAxiomName :: BuiltInSyntax -> Module -> FastString -> Unique
+ -> CoAxiom Branched -> Name
+mkWiredInCoAxiomName built_in modu fs unique ax
+ = mkWiredInName modu (mkTcOccFS fs) unique
+ (ACoAxiom ax) -- Relevant CoAxiom
+ built_in
+
-- See Note [Kind-changing of (~) and Coercible]
eqTyConName, eqBoxDataConName :: Name
eqTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon
@@ -896,14 +911,14 @@ eqTyCon = mkAlgTyCon eqTyConName
where
kv = kKiVar
k = mkTyVarTy kv
- a:b:_ = tyVarList k
+ [a,b] = mkTemplateTyVars [k,k]
eqBoxDataCon :: DataCon
eqBoxDataCon = pcDataCon eqBoxDataConName args [TyConApp eqPrimTyCon (map mkTyVarTy args)] eqTyCon
where
kv = kKiVar
k = mkTyVarTy kv
- a:b:_ = tyVarList k
+ [a,b] = mkTemplateTyVars [k,k]
args = [kv, a, b]
@@ -914,7 +929,7 @@ coercibleTyCon = mkClassTyCon
where kind = (ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
kv = kKiVar
k = mkTyVarTy kv
- a:b:_ = tyVarList k
+ [a,b] = mkTemplateTyVars [k,k]
tvs = [kv, a, b]
rhs = DataTyCon [coercibleDataCon] False
@@ -923,8 +938,59 @@ coercibleDataCon = pcDataCon coercibleDataConName args [TyConApp eqReprPrimTyCon
where
kv = kKiVar
k = mkTyVarTy kv
- a:b:_ = tyVarList k
+ [a,b] = mkTemplateTyVars [k,k]
args = [kv, a, b]
coercibleClass :: Class
coercibleClass = mkClass (tyConTyVars coercibleTyCon) [] [] [] [] [] (mkAnd []) coercibleTyCon
+
+{-
+Note [The Implicit Parameter class]
+
+Implicit parameters `?x :: a` are desugared into dictionaries for the
+class `IP "x" a`, which is defined (in GHC.Classes) as
+
+ class IP (x :: Symbol) a | x -> a
+
+This class is wired-in so that `error` and `undefined`, which have
+wired-in types, can use the implicit-call-stack feature to provide
+a call-stack alongside the error message.
+-}
+
+ipDataConName, ipTyConName, ipCoName :: Name
+ipDataConName = mkWiredInDataConName UserSyntax gHC_CLASSES (fsLit "IP")
+ ipDataConKey ipDataCon
+ipTyConName = mkWiredInTyConName UserSyntax gHC_CLASSES (fsLit "IP")
+ ipTyConKey ipTyCon
+ipCoName = mkWiredInCoAxiomName BuiltInSyntax gHC_CLASSES (fsLit "NTCo:IP")
+ ipCoNameKey (toBranchedAxiom ipCoAxiom)
+
+-- See Note [The Implicit Parameter class]
+ipTyCon :: TyCon
+ipTyCon = mkClassTyCon ipTyConName kind [ip,a] [] rhs ipClass NonRecursive
+ where
+ kind = mkArrowKinds [typeSymbolKind, liftedTypeKind] constraintKind
+ [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind]
+ rhs = NewTyCon ipDataCon (mkTyVarTy a) ([], mkTyVarTy a) ipCoAxiom
+
+ipCoAxiom :: CoAxiom Unbranched
+ipCoAxiom = mkNewTypeCo ipCoName ipTyCon [ip,a] [Nominal, Nominal] (mkTyVarTy a)
+ where
+ [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind]
+
+ipDataCon :: DataCon
+ipDataCon = pcDataCon ipDataConName [ip,a] ts ipTyCon
+ where
+ [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind]
+ ts = [mkTyVarTy a]
+
+ipClass :: Class
+ipClass = mkClass (tyConTyVars ipTyCon) [([ip], [a])] [] [] [] [] (mkAnd [])
+ ipTyCon
+ where
+ [ip, a] = tyConTyVars ipTyCon
+
+-- this is a fake version of the CallStack TyCon so we can refer to it
+-- in MkCore.errorTy
+callStackTyCon :: TyCon
+callStackTyCon = pcNonRecDataTyCon callStackTyConName Nothing [] []
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 8a7ca4d5c1..897828d5ec 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -37,6 +37,7 @@ import FamInst( tcGetFamInstEnvs )
import TyCon
import TcType
import TysPrim
+import TysWiredIn
import Id
import Var
import VarSet
@@ -56,7 +57,7 @@ import BasicTypes
import Outputable
import FastString
import Type(mkStrLitTy)
-import PrelNames( ipClassName, gHC_PRIM )
+import PrelNames( gHC_PRIM )
import TcValidity (checkValidType)
import Control.Monad
@@ -225,8 +226,7 @@ tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
- = do { ipClass <- tcLookupClass ipClassName
- ; (given_ips, ip_binds') <-
+ = do { (given_ips, ip_binds') <-
mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
-- If the binding binds ?x = E, we must now
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index d2b0c59244..354515a72e 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -46,7 +46,7 @@ import Var
import VarSet
import VarEnv
import TysWiredIn
-import TysPrim( intPrimTy, addrPrimTy )
+import TysPrim( intPrimTy )
import PrimOp( tagToEnumKey )
import PrelNames
import DynFlags
@@ -191,7 +191,6 @@ tcExpr (NegApp expr neg_expr) res_ty
tcExpr (HsIPVar x) res_ty
= do { let origin = IPOccOrigin x
- ; ipClass <- tcLookupClass ipClassName
{- Implicit parameters must have a *tau-type* not a.
type scheme. We enforce this by creating a fresh
type variable as its type. (Because res_ty may not
@@ -1067,25 +1066,19 @@ tcInferIdWithOrig orig id_name
= do { dflags <- getDynFlags
; if gopt Opt_IgnoreAsserts dflags
then tc_infer_id orig id_name
- else tc_infer_assert dflags orig }
+ else tc_infer_assert orig }
| otherwise
= tc_infer_id orig id_name
-tc_infer_assert :: DynFlags -> CtOrigin -> TcM (HsExpr TcId, TcRhoType)
+tc_infer_assert :: CtOrigin -> TcM (HsExpr TcId, TcRhoType)
-- Deal with an occurrence of 'assert'
-- See Note [Adding the implicit parameter to 'assert']
-tc_infer_assert dflags orig
- = do { sloc <- getSrcSpanM
- ; assert_error_id <- tcLookupId assertErrorName
+tc_infer_assert orig
+ = do { assert_error_id <- tcLookupId assertErrorName
; (wrap, id_rho) <- deeplyInstantiate orig (idType assert_error_id)
- ; let (arg_ty, res_ty) = case tcSplitFunTy_maybe id_rho of
- Nothing -> pprPanic "assert type" (ppr id_rho)
- Just arg_res -> arg_res
- ; ASSERT( arg_ty `tcEqType` addrPrimTy )
- return (HsApp (L sloc (mkHsWrap wrap (HsVar assert_error_id)))
- (L sloc (srcSpanPrimLit dflags sloc))
- , res_ty) }
+ ; return (mkHsWrap wrap (HsVar assert_error_id), id_rho)
+ }
tc_infer_id :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
-- Return type is deeply instantiated
@@ -1133,17 +1126,12 @@ tc_infer_id orig id_name
| isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
| otherwise = return ()
-srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr TcId
-srcSpanPrimLit dflags span
- = HsLit (HsStringPrim "" (unsafeMkByteString
- (showSDocOneLine dflags (ppr span))))
-
{-
Note [Adding the implicit parameter to 'assert']
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The typechecker transforms (assert e1 e2) to (assertError "Foo.hs:27"
-e1 e2). This isn't really the Right Thing because there's no way to
-"undo" if you want to see the original source code in the typechecker
+The typechecker transforms (assert e1 e2) to (assertError e1 e2).
+This isn't really the Right Thing because there's no way to "undo"
+if you want to see the original source code in the typechecker
output. We'll have fix this in due course, when we care more about
being able to reconstruct the exact original program.
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 605929efbe..39ab4e621b 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -72,7 +72,7 @@ import Util
import Data.Maybe( isNothing )
import Control.Monad ( unless, when, zipWithM )
-import PrelNames( ipClassName, funTyConKey, allNameStrings )
+import PrelNames( funTyConKey, allNameStrings )
{-
----------------------------
@@ -490,7 +490,6 @@ tc_hs_type hs_ty@(HsExplicitTupleTy _ tys) exp_kind
tc_hs_type ipTy@(HsIParamTy n ty) exp_kind
= do { ty' <- tc_lhs_type ty ekLifted
; checkExpectedKind ipTy constraintKind exp_kind
- ; ipClass <- tcLookupClass ipClassName
; let n' = mkStrLitTy $ hsIPNameFS n
; return (mkClassPred ipClass [n',ty'])
}
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 0684fdf1d5..6feb3f0c33 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -20,9 +20,9 @@ import CoAxiom(sfInteractTop, sfInteractInert)
import Var
import TcType
-import PrelNames ( knownNatClassName, knownSymbolClassName, ipClassNameKey,
+import PrelNames ( knownNatClassName, knownSymbolClassName,
callStackTyConKey, typeableClassName )
-import TysWiredIn ( typeNatKind, typeSymbolKind )
+import TysWiredIn ( ipClass, typeNatKind, typeSymbolKind )
import Id( idType )
import Class
import TyCon
@@ -704,7 +704,7 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs
else
continueWith workItem }
- | cls `hasKey` ipClassNameKey
+ | cls == ipClass
, isGiven ev_w
= interactGivenIP inerts workItem
@@ -1755,7 +1755,7 @@ Other notes:
-- i.e. (IP "name" CallStack)
isCallStackIP :: CtLoc -> Class -> [Type] -> Maybe (EvTerm -> EvCallStack)
isCallStackIP loc cls tys
- | cls `hasKey` ipClassNameKey
+ | cls == ipClass
, [_ip_name, ty] <- tys
, Just (tc, _) <- splitTyConApp_maybe ty
, tc `hasKey` callStackTyConKey
diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs
index 9815958da7..18d3b32fdd 100644
--- a/compiler/typecheck/TcTypeNats.hs
+++ b/compiler/typecheck/TcTypeNats.hs
@@ -29,7 +29,7 @@ import TysWiredIn ( typeNatKind, typeSymbolKind
, promotedEQDataCon
, promotedGTDataCon
)
-import TysPrim ( tyVarList, mkArrowKinds )
+import TysPrim ( mkArrowKinds, mkTemplateTyVars )
import PrelNames ( gHC_TYPELITS
, typeNatAddTyFamNameKey
, typeNatMulTyFamNameKey
@@ -106,7 +106,7 @@ typeNatLeqTyCon :: TyCon
typeNatLeqTyCon =
mkFamilyTyCon name
(mkArrowKinds [ typeNatKind, typeNatKind ] boolKind)
- (take 2 $ tyVarList typeNatKind)
+ (mkTemplateTyVars [ typeNatKind, typeNatKind ])
(BuiltInSynFamTyCon ops)
NoParentTyCon
@@ -123,7 +123,7 @@ typeNatCmpTyCon :: TyCon
typeNatCmpTyCon =
mkFamilyTyCon name
(mkArrowKinds [ typeNatKind, typeNatKind ] orderingKind)
- (take 2 $ tyVarList typeNatKind)
+ (mkTemplateTyVars [ typeNatKind, typeNatKind ])
(BuiltInSynFamTyCon ops)
NoParentTyCon
@@ -140,7 +140,7 @@ typeSymbolCmpTyCon :: TyCon
typeSymbolCmpTyCon =
mkFamilyTyCon name
(mkArrowKinds [ typeSymbolKind, typeSymbolKind ] orderingKind)
- (take 2 $ tyVarList typeSymbolKind)
+ (mkTemplateTyVars [ typeSymbolKind, typeSymbolKind ])
(BuiltInSynFamTyCon ops)
NoParentTyCon
@@ -162,7 +162,7 @@ mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon
mkTypeNatFunTyCon2 op tcb =
mkFamilyTyCon op
(mkArrowKinds [ typeNatKind, typeNatKind ] typeNatKind)
- (take 2 $ tyVarList typeNatKind)
+ (mkTemplateTyVars [ typeNatKind, typeNatKind ])
(BuiltInSynFamTyCon tcb)
NoParentTyCon
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 1ee53ba582..a2feeef723 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -163,7 +163,7 @@ import TyCon
import TysPrim
import {-# SOURCE #-} TysWiredIn ( eqTyCon, coercibleTyCon, typeNatKind, typeSymbolKind )
import PrelNames ( eqTyConKey, coercibleTyConKey,
- ipClassNameKey, openTypeKindTyConKey,
+ ipTyConKey, openTypeKindTyConKey,
constraintKindTyConKey, liftedTypeKindTyConKey )
import CoAxiom
@@ -908,10 +908,10 @@ isIPPred ty = case tyConAppTyCon_maybe ty of
_ -> False
isIPTyCon :: TyCon -> Bool
-isIPTyCon tc = tc `hasKey` ipClassNameKey
+isIPTyCon tc = tc `hasKey` ipTyConKey
isIPClass :: Class -> Bool
-isIPClass cls = cls `hasKey` ipClassNameKey
+isIPClass cls = cls `hasKey` ipTyConKey
-- Class and it corresponding TyCon have the same Unique
isCTupleClass :: Class -> Bool
diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs
index e2be8a0ec4..291e14ccc1 100644
--- a/compiler/types/TypeRep.hs
+++ b/compiler/types/TypeRep.hs
@@ -703,7 +703,7 @@ pprTyTcApp :: TyPrec -> TyCon -> [Type] -> SDoc
-- Used for types only; so that we can make a
-- special case for type-level lists
pprTyTcApp p tc tys
- | tc `hasKey` ipClassNameKey
+ | tc `hasKey` ipTyConKey
, [LitTy (StrTyLit n),ty] <- tys
= maybeParen p FunPrec $
char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty
View Lorry Controller Status