Commit 9729fe7c authored by batterseapower's avatar batterseapower

Implement -XConstraintKind

Basically as documented in http://hackage.haskell.org/trac/ghc/wiki/KindFact,
this patch adds a new kind Constraint such that:

  Show :: * -> Constraint
  (?x::Int) :: Constraint
  (Int ~ a) :: Constraint

And you can write *any* type with kind Constraint to the left of (=>):
even if that type is a type synonym, type variable, indexed type or so on.

The following (somewhat related) changes are also made:
 1. We now box equality evidence. This is required because we want
    to give (Int ~ a) the *lifted* kind Constraint
 2. For similar reasons, implicit parameters can now only be of
    a lifted kind. (?x::Int#) => ty is now ruled out
 3. Implicit parameter constraints are now allowed in superclasses
    and instance contexts (this just falls out as OK with the new
    constraint solver)

Internally the following major changes were made:
 1. There is now no PredTy in the Type data type. Instead
    GHC checks the kind of a type to figure out if it is a predicate
 2. There is now no AClass TyThing: we represent classes as TyThings
    just as a ATyCon (classes had TyCons anyway)
 3. What used to be (~) is now pretty-printed as (~#). The box
    constructor EqBox :: (a ~# b) -> (a ~ b)
 4. The type LCoercion is used internally in the constraint solver
    and type checker to represent coercions with free variables
    of type (a ~ b) rather than (a ~# b)
parent b98267ad
......@@ -44,7 +44,8 @@ module BasicTypes(
Boxity(..), isBoxed,
TupCon(..), tupleParens,
TupleSort(..), tupleSortBoxity, boxityNormalTupleSort,
tupleParens,
OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc,
isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc,
......@@ -168,9 +169,10 @@ early in the hierarchy), but also in HsSyn.
\begin{code}
newtype IPName name = IPName name -- ?x
deriving( Eq, Ord, Data, Typeable )
-- Ord is used in the IP name cache finite map
-- (used in HscTypes.OrigIParamCache)
deriving( Eq, Data, Typeable )
instance Functor IPName where
fmap = mapIPName
ipNameName :: IPName name -> name
ipNameName (IPName n) = n
......@@ -284,7 +286,7 @@ instance Outputable TopLevelFlag where
%************************************************************************
%* *
Top-level/not-top level flag
Boxity flag
%* *
%************************************************************************
......@@ -382,14 +384,25 @@ pprSafeOverlap False = empty
%************************************************************************
\begin{code}
data TupCon = TupCon Boxity Arity
instance Eq TupCon where
(TupCon b1 a1) == (TupCon b2 a2) = b1==b2 && a1==a2
tupleParens :: Boxity -> SDoc -> SDoc
tupleParens Boxed p = parens p
tupleParens Unboxed p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
data TupleSort
= BoxedTuple
| UnboxedTuple
| FactTuple
deriving( Eq, Data, Typeable )
tupleSortBoxity :: TupleSort -> Boxity
tupleSortBoxity BoxedTuple = Boxed
tupleSortBoxity UnboxedTuple = Unboxed
tupleSortBoxity FactTuple = Boxed
boxityNormalTupleSort :: Boxity -> TupleSort
boxityNormalTupleSort Boxed = BoxedTuple
boxityNormalTupleSort Unboxed = UnboxedTuple
tupleParens :: TupleSort -> SDoc -> SDoc
tupleParens BoxedTuple p = parens p
tupleParens FactTuple p = parens p -- The user can't write fact tuples directly, we overload the (,,) syntax
tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
\end{code}
%************************************************************************
......
......@@ -47,11 +47,11 @@ import TyCon
import Class
import Name
import Var
import BasicTypes
import Outputable
import Unique
import ListSetOps
import Util
import BasicTypes
import FastString
import Module
......@@ -535,7 +535,7 @@ mkDataCon name declared_infix
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
full_theta = eqSpecPreds eq_spec ++ theta
real_arg_tys = mkPredTys full_theta ++ orig_arg_tys
real_arg_tys = full_theta ++ orig_arg_tys
real_stricts = map mk_dict_strict_mark full_theta ++ arg_stricts
-- Representation arguments and demands
......@@ -551,8 +551,9 @@ eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ]
mk_dict_strict_mark :: PredType -> HsBang
mk_dict_strict_mark pred | isStrictPred pred = HsStrict
| otherwise = HsNoBang
mk_dict_strict_mark pred | isEqPred pred = HsUnpack
| otherwise = HsNoBang
\end{code}
\begin{code}
......@@ -658,7 +659,7 @@ dataConStrictMarks = dcStrictMarks
-- | Strictness of evidence arguments to the wrapper function
dataConExStricts :: DataCon -> [HsBang]
-- Usually empty, so we don't bother to cache this
dataConExStricts dc = map mk_dict_strict_mark $ (dataConTheta dc)
dataConExStricts dc = map mk_dict_strict_mark (dataConTheta dc)
-- | Source-level arity of the data constructor
dataConSourceArity :: DataCon -> Arity
......@@ -746,7 +747,7 @@ dataConUserType (MkData { dcUnivTyVars = univ_tvs,
dcOtherTheta = theta, dcOrigArgTys = arg_tys,
dcOrigResTy = res_ty })
= mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
mkFunTys (mkPredTys theta) $
mkFunTys theta $
mkFunTys arg_tys $
res_ty
......@@ -841,11 +842,16 @@ dataConCannotMatch tys con
| all isTyVarTy tys = False -- Also common
| otherwise
= typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2)
| EqPred ty1 ty2 <- theta ]
| (ty1, ty2) <- concatMap (predEqs . predTypePredTree) theta ]
where
dc_tvs = dataConUnivTyVars con
theta = dataConTheta con
subst = zipTopTvSubst dc_tvs tys
-- TODO: could gather equalities from superclasses too
predEqs (EqPred ty1 ty2) = [(ty1, ty2)]
predEqs (TuplePred ts) = concatMap predEqs ts
predEqs _ = []
\end{code}
%************************************************************************
......@@ -935,4 +941,4 @@ computeRep stricts tys
where
(_tycon, _tycon_args, arg_dc, arg_tys)
= deepSplitProductType "unbox_strict_arg_ty" ty
\end{code}
\end{code}
\ No newline at end of file
......@@ -293,20 +293,23 @@ mkDataConIds wrap_name wkr_name data_con
-- extra constraints where necessary.
wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
ev_tys = mkPredTys other_theta
ev_tys = other_theta
wrap_ty = mkForAllTys wrap_tvs $
mkFunTys ev_tys $
mkFunTys orig_arg_tys $ res_ty
----------- Wrappers for algebraic data types --------------
alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
alg_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
alg_wrap_info = noCafIdInfo
`setArityInfo` wrap_arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
`setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` wrap_unf
`setStrictnessInfo` Just wrap_sig
-- We need to get the CAF info right here because TidyPgm
-- does not tidy the IdInfo of implicit bindings (like the wrapper)
-- so it not make sure that the CAF info is sane
all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info)
......@@ -339,6 +342,8 @@ mkDataConIds wrap_name wkr_name data_con
`mkVarApps` ex_tvs
`mkCoApps` map (mkReflCo . snd) eq_spec
`mkVarApps` reverse rep_ids
-- Dont box the eq_spec coercions since they are
-- marked as HsUnpack by mk_dict_strict_mark
(ev_args,i2) = mkLocals 1 ev_tys
(id_args,i3) = mkLocals i2 orig_arg_tys
......@@ -481,7 +486,7 @@ mkDictSelId no_unf name clas
the_arg_id = arg_ids !! val_index
pred = mkClassPred clas (mkTyVarTys tyvars)
dict_id = mkTemplateLocal 1 $ mkPredTy pred
dict_id = mkTemplateLocal 1 pred
arg_ids = mkTemplateLocalsNum 2 arg_tys
rhs = mkLams tyvars (Lam dict_id rhs_body)
......@@ -838,7 +843,7 @@ mkDictFunId dfun_name tvs theta clas tys
mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type
mkDictFunTy tvs theta clas tys
= mkSigmaTy tvs theta (mkDictTy clas tys)
= mkSigmaTy tvs theta (mkClassPred clas tys)
\end{code}
......@@ -1038,7 +1043,7 @@ voidArgId -- :: State# RealWorld
coercionTokenId :: Id -- :: () ~ ()
coercionTokenId -- Used to replace Coercion terms when we go to STG
= pcMiscPrelId coercionTokenName
(mkTyConApp eqPredPrimTyCon [unitTy, unitTy])
(mkTyConApp eqPrimTyCon [unitTy, unitTy])
noCafIdInfo
\end{code}
......
......@@ -40,7 +40,7 @@ module Name (
mkSystemName, mkSystemNameAt,
mkInternalName, mkDerivedInternalName,
mkSystemVarName, mkSysTvName,
mkFCallName, mkIPName,
mkFCallName,
mkTickBoxOpName,
mkExternalName, mkWiredInName,
......@@ -302,14 +302,6 @@ mkTickBoxOpName :: Unique -> String -> Name
mkTickBoxOpName uniq str
= Name { n_uniq = getKeyFastInt uniq, n_sort = Internal,
n_occ = mkVarOcc str, n_loc = noSrcSpan }
-- | Make the name of an implicit parameter
mkIPName :: Unique -> OccName -> Name
mkIPName uniq occ
= Name { n_uniq = getKeyFastInt uniq,
n_sort = Internal,
n_occ = occ,
n_loc = noSrcSpan }
\end{code}
\begin{code}
......
......@@ -51,7 +51,7 @@ module OccName (
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
......@@ -541,12 +541,12 @@ isDerivedOccName occ =
\begin{code}
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc,
mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkGenD, mkGenR, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc,
mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkGenD, mkGenR, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
:: OccName -> OccName
-- These derived variables have a prefix that no Haskell value could have
......@@ -555,8 +555,7 @@ mkWorkerOcc = mk_simple_deriv varName "$w"
mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
mkGenDefMethodOcc = mk_simple_deriv varName "$gdm"
mkClassOpAuxOcc = mk_simple_deriv varName "$c"
mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies
mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon
mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies as a tycon/datacon
mkClassDataConOcc = mk_simple_deriv dataName "D:" -- We go straight to the "real" data con
-- for datacons from classes
mkDictOcc = mk_simple_deriv varName "$d"
......@@ -624,8 +623,8 @@ mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ
mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3
-> OccName -- ^ Class, e.g. @Ord@
-> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@
mkSuperDictSelOcc index cls_occ
= mk_deriv varName "$p" (show index ++ occNameString cls_occ)
mkSuperDictSelOcc index cls_tc_occ
= mk_deriv varName "$p" (show index ++ occNameString cls_tc_occ)
mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName'
-> OccName -- ^ Local name, e.g. @sat@
......@@ -751,24 +750,43 @@ tidyOccName in_scope occ@(OccName occ_sp fs)
%************************************************************************
\begin{code}
mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName
mkTupleOcc ns bx ar = OccName ns (mkFastString str)
mkTupleOcc :: NameSpace -> TupleSort -> Arity -> OccName
mkTupleOcc ns sort ar = OccName ns (mkFastString str)
where
-- no need to cache these, the caching is done in the caller
-- (TysWiredIn.mk_tuple)
str = case bx of
Boxed -> '(' : commas ++ ")"
Unboxed -> '(' : '#' : commas ++ "#)"
str = case sort of
UnboxedTuple -> '(' : '#' : commas ++ "#)"
BoxedTuple -> '(' : commas ++ ")"
FactTuple -> '(' : commas ++ ")"
-- Cute hack: reuse the standard tuple OccNames (and hence code)
-- for fact tuples, but give them different Uniques so they are not equal.
--
-- You might think that this will go wrong because isTupleOcc_maybe won't
-- be able to tell the difference between boxed tuples and fact tuples. BUT:
-- 1. Fact tuples never occur directly in user code, so it doesn't matter
-- that we can't detect them in Orig OccNames originating from the user
-- programs (or those built by setRdrNameSpace used on an Exact tuple Name)
-- 2. Interface files have a special representation for tuple *occurrences*
-- in IfaceTyCons, their workers (in IfaceSyn) and their DataCons (in case
-- alternatives). Thus we don't rely on the OccName to figure out what kind
-- of tuple an occurrence was trying to use in these situations.
-- 3. We *don't* represent tuple data type declarations specially, so those
-- are still turned into wired-in names via isTupleOcc_maybe. But that's OK
-- because we don't actually need to declare fact tuples thanks to this hack.
--
-- So basically any OccName like (,,) flowing to isTupleOcc_maybe will always
-- refer to the standard boxed tuple. Cool :-)
commas = take (ar-1) (repeat ',')
isTupleOcc_maybe :: OccName -> Maybe (NameSpace, Boxity, Arity)
isTupleOcc_maybe :: OccName -> Maybe (NameSpace, TupleSort, Arity)
-- Tuples are special, because there are so many of them!
isTupleOcc_maybe (OccName ns fs)
= case unpackFS fs of
'(':'#':',':rest -> Just (ns, Unboxed, 2 + count_commas rest)
'(':',':rest -> Just (ns, Boxed, 2 + count_commas rest)
_other -> Nothing
'(':'#':',':rest -> Just (ns, UnboxedTuple, 2 + count_commas rest)
'(':',':rest -> Just (ns, BoxedTuple, 2 + count_commas rest)
_other -> Nothing
where
count_commas (',':rest) = 1 + count_commas rest
count_commas _ = 0
......
......@@ -99,6 +99,10 @@ data RealSrcLoc
{-# UNPACK #-} !Int -- line number, begins at 1
{-# UNPACK #-} !Int -- column number, begins at 1
#ifdef DEBUG
deriving Show -- debugging
#endif
data SrcLoc
= RealSrcLoc {-# UNPACK #-}!RealSrcLoc
| UnhelpfulLoc FastString -- Just a general indication
......
......@@ -34,9 +34,7 @@ module Unique (
newTagUnique, -- Used in CgCase
initTyVarUnique,
isTupleKey,
-- ** Making built-in uniques
-- ** Making built-in uniques
-- now all the built-in Uniques (and functions to make them)
-- [the Oh-So-Wonderful Haskell module system wins again...]
......@@ -47,7 +45,7 @@ module Unique (
mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
mkBuiltinUnique,
......@@ -105,8 +103,6 @@ getKeyFastInt :: Unique -> FastInt -- for Var
incrUnique :: Unique -> Unique
deriveUnique :: Unique -> Int -> Unique
newTagUnique :: Unique -> Char -> Unique
isTupleKey :: Unique -> Bool
\end{code}
......@@ -311,9 +307,9 @@ Allocation of unique supply characters:
mkAlphaTyVarUnique :: Int -> Unique
mkPreludeClassUnique :: Int -> Unique
mkPreludeTyConUnique :: Int -> Unique
mkTupleTyConUnique :: Boxity -> Int -> Unique
mkTupleTyConUnique :: TupleSort -> Int -> Unique
mkPreludeDataConUnique :: Int -> Unique
mkTupleDataConUnique :: Boxity -> Int -> Unique
mkTupleDataConUnique :: TupleSort -> Int -> Unique
mkPrimOpIdUnique :: Int -> Unique
mkPreludeMiscIdUnique :: Int -> Unique
mkPArrDataConUnique :: Int -> Unique
......@@ -327,8 +323,9 @@ mkPreludeClassUnique i = mkUnique '2' i
-- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info.
mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique Boxed a = mkUnique '4' (3*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
mkTupleTyConUnique BoxedTuple a = mkUnique '4' (3*a)
mkTupleTyConUnique UnboxedTuple a = mkUnique '5' (3*a)
mkTupleTyConUnique FactTuple a = mkUnique 'k' (3*a)
-- Data constructor keys occupy *two* slots. The first is used for the
-- data constructor itself and its wrapper function (the function that
......@@ -337,13 +334,9 @@ mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
-- representation).
mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic
mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a)
-- This one is used for a tiresome reason
-- to improve a consistency-checking error check in the renamer
isTupleKey u = case unpkUnique u of
(tag,_) -> tag == '4' || tag == '5' || tag == '7' || tag == '8'
mkTupleDataConUnique BoxedTuple a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique UnboxedTuple a = mkUnique '8' (2*a)
mkTupleDataConUnique FactTuple a = mkUnique 'h' (2*a)
mkPrimOpIdUnique op = mkUnique '9' op
mkPreludeMiscIdUnique i = mkUnique '0' i
......
......@@ -32,7 +32,7 @@
module Var (
-- * The main data type and synonyms
Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EqVar, EvId, IpId,
-- ** Taking 'Var's apart
varName, varUnique, varType,
......@@ -98,11 +98,12 @@ type DFunId = Id -- A dictionary function
type EvId = Id -- Term-level evidence: DictId or IpId
type DictId = EvId -- A dictionary variable
type IpId = EvId -- A term-level implicit parameter
type EqVar = EvId -- Boxed equality evidence
type TyVar = Var
type CoVar = Id -- A coercion variable is simply an Id
-- variable of kind @ty1 ~ ty2@. Hence its
-- 'varType' is always @PredTy (EqPred t1 t2)@
-- variable of kind @#@. Its
-- 'varType' is always @ty1 ~# ty2@
\end{code}
%************************************************************************
......
......@@ -1091,15 +1091,9 @@ getTyDescription ty
AppTy fun _ -> getTyDescription fun
FunTy _ res -> '-' : '>' : fun_result res
TyConApp tycon _ -> getOccString tycon
PredTy sty -> getPredTyDescription sty
ForAllTy _ ty -> getTyDescription ty
}
where
fun_result (FunTy _ res) = '>' : fun_result res
fun_result other = getTyDescription other
getPredTyDescription :: PredType -> String
getPredTyDescription (ClassP cl _) = getOccString cl
getPredTyDescription (IParam ip _) = getOccString (ipNameName ip)
getPredTyDescription (EqPred _ _) = "Type equality"
\end{code}
......@@ -855,18 +855,12 @@ getTyDescription ty
AppTy fun _ -> getTyDescription fun
FunTy _ res -> '-' : '>' : fun_result res
TyConApp tycon _ -> getOccString tycon
PredTy sty -> getPredTyDescription sty
ForAllTy _ ty -> getTyDescription ty
}
where
fun_result (FunTy _ res) = '>' : fun_result res
fun_result other = getTyDescription other
getPredTyDescription :: PredType -> String
getPredTyDescription (ClassP cl _) = getOccString cl
getPredTyDescription (IParam ip _) = getOccString (ipNameName ip)
getPredTyDescription (EqPred {}) = "Type equality"
--------------------------------------
-- CmmInfoTable-related things
--------------------------------------
......
......@@ -20,6 +20,7 @@ import Bag
import Literal
import DataCon
import TysWiredIn
import TysPrim
import Var
import VarEnv
import VarSet
......@@ -27,13 +28,12 @@ import Name
import Id
import PprCore
import ErrUtils
import Coercion
import SrcLoc
import Kind
import Type
import TypeRep
import Coercion
import TyCon
import Class
import BasicTypes
import StaticFlags
import ListSetOps
......@@ -281,10 +281,24 @@ lintCoreExpr (Let (Rec pairs) body)
bndrs = map fst pairs
(_, dups) = removeDups compare bndrs
lintCoreExpr e@(App fun arg)
= do { fun_ty <- lintCoreExpr fun
; addLoc (AnExpr e) $
lintCoreArg fun_ty arg }
lintCoreExpr e@(App _ _)
| Var x <- fun -- Greivous hack for Eq# construction: Eq# may have type arguments
-- of kind (* -> *) but its type insists on *. When we have polymorphic kinds,
-- we should do this properly
, Just dc <- isDataConWorkId_maybe x
, dc == eqBoxDataCon
, [Type arg_ty1, Type arg_ty2, co_e] <- args
= do arg_kind1 <- lintType arg_ty1
arg_kind2 <- lintType arg_ty2
unless (arg_kind1 `eqKind` arg_kind2)
(addErrL (mkEqBoxKindErrMsg arg_ty1 arg_ty2))
lintCoreArg (mkCoercionType arg_ty1 arg_ty2 `mkFunTy` mkEqPred (arg_ty1, arg_ty2)) co_e
| otherwise
= do { fun_ty <- lintCoreExpr fun
; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
where
(fun, args) = collectArgs e
lintCoreExpr (Lam var expr)
= addLoc (LambdaBodyOf var) $
......@@ -339,7 +353,7 @@ lintCoreExpr (Type ty)
lintCoreExpr (Coercion co)
= do { co' <- lintInCo co
; let Pair ty1 ty2 = coercionKind co'
; return (mkPredTy $ EqPred ty1 ty2) }
; return (mkCoercionType ty1 ty2) }
\end{code}
%************************************************************************
......@@ -646,6 +660,10 @@ lintCoercion (ForAllCo v co)
; return (ForAllTy v s, ForAllTy v t) }
lintCoercion (CoVarCo cv)
| not (isCoVar cv)
= failWithL (hang (ptext (sLit "Bad CoVarCo:") <+> ppr cv)
2 (ptext (sLit "With offending type:") <+> ppr (varType cv)))
| otherwise
= do { checkTyCoVarInScope cv
; return (coVarKind cv) }
......@@ -716,7 +734,9 @@ lintType ty@(FunTy t1 t2)
= lint_ty_app ty (tyConKind funTyCon) [t1,t2]
lintType ty@(TyConApp tc tys)
| tc `hasKey` eqPredPrimTyConKey -- See Note [The (~) TyCon] in TysPrim
| tc `hasKey` eqPrimTyConKey -- See Note [The ~# TyCon] in TysPrim
= lint_prim_eq_pred ty tys
| tc `hasKey` eqTyConKey
= lint_eq_pred ty tys
| tyConHasKind tc
= lint_ty_app ty (tyConKind tc) tys
......@@ -727,20 +747,6 @@ lintType (ForAllTy tv ty)
= do { lintTyBndrKind tv
; addInScopeVar tv (lintType ty) }
lintType ty@(PredTy (ClassP cls tys))
= lint_ty_app ty (tyConKind (classTyCon cls)) tys
lintType (PredTy (IParam _ p_ty))
= lintType p_ty
lintType ty@(PredTy (EqPred t1 t2))
= do { k1 <- lintType t1
; k2 <- lintType t2
; unless (k1 `eqKind` k2)
(addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:")
, nest 2 (ppr ty) ]))
; return unliftedTypeKind }
----------------
lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
lint_ty_app ty k tys
......@@ -748,7 +754,21 @@ lint_ty_app ty k tys
; lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k ks }
lint_eq_pred :: Type -> [OutType] -> LintM Kind
lint_eq_pred ty arg_tys
lint_eq_pred ty arg_tys = case arg_tys of
[ty1, ty2] -> do { k1 <- lintType ty1
; k2 <- lintType ty2
; unless (k1 `eqKind` k2)
(addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:")
, nest 2 (ppr ty) ]))
; return constraintKind }
[ty1] -> do { k1 <- lintType ty1;
return (k1 `mkFunTy` constraintKind) }
[] -> do { return (typeKind ty) }
_ -> failWithL (ptext (sLit "Oversaturated (~) type") <+> ppr ty)
lint_prim_eq_pred :: Type -> [OutType] -> LintM Kind
lint_prim_eq_pred ty arg_tys
| [ty1,ty2] <- arg_tys
= do { k1 <- lintType ty1
; k2 <- lintType ty2
......@@ -756,7 +776,7 @@ lint_eq_pred ty arg_tys
(ptext (sLit "Mismatched arg kinds:") <+> ppr ty)
; return unliftedTypeKind }
| otherwise
= failWithL (ptext (sLit "Unsaturated (~) type") <+> ppr ty)
= failWithL (ptext (sLit "Unsaturated ~# type") <+> ppr ty)
----------------
check_co_app :: Coercion -> Kind -> [OutType] -> LintM ()
......@@ -926,7 +946,7 @@ lookupIdInScope id
oneTupleDataConId :: Id -- Should not happen
oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
oneTupleDataConId = dataConWorkId (tupleCon BoxedTuple 1)
checkBndrIdInScope :: Var -> Var -> LintM ()
checkBndrIdInScope binder id
......@@ -1127,6 +1147,14 @@ mkStrictMsg binder
]
mkEqBoxKindErrMsg :: Type -> Type -> Message
mkEqBoxKindErrMsg ty1 ty2
= vcat [ptext (sLit "Kinds don't match in type arguments of Eq#:"),
hang (ptext (sLit "Arg type 1:"))
4 (ppr ty1 <+> dcolon <+> ppr (typeKind ty1)),
hang (ptext (sLit "Arg type 2:"))
4 (ppr ty2 <+> dcolon <+> ppr (typeKind ty2))]
mkKindErrMsg :: TyVar -> Type -> Message
mkKindErrMsg tyvar arg_ty
= vcat [ptext (sLit "Kinds don't match in type application:"),
......
......@@ -51,6 +51,7 @@ import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substC
import OptCoercion ( optCoercion )
import PprCore ( pprCoreBindings, pprRules )
import PrelNames ( eqBoxDataConKey )