Commit e8aa8ccb authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Implement "roles" into GHC.

Roles are a solution to the GeneralizedNewtypeDeriving type-safety
problem.

Roles were first described in the "Generative type abstraction" paper,
by Stephanie Weirich, Dimitrios Vytiniotis, Simon PJ, and Steve Zdancewic.
The implementation is a little different than that paper. For a quick
primer, check out Note [Roles] in Coercion. Also see
http://ghc.haskell.org/trac/ghc/wiki/Roles
and
http://ghc.haskell.org/trac/ghc/wiki/RolesImplementation
For a more formal treatment, check out docs/core-spec/core-spec.pdf.

This fixes Trac #1496, #4846, #7148.
parent 303d3de9
...@@ -650,11 +650,12 @@ mkDataCon name declared_infix ...@@ -650,11 +650,12 @@ mkDataCon name declared_infix
| isJust (promotableTyCon_maybe rep_tycon) | isJust (promotableTyCon_maybe rep_tycon)
-- The TyCon is promotable only if all its datacons -- The TyCon is promotable only if all its datacons
-- are, so the promoteType for prom_kind should succeed -- are, so the promoteType for prom_kind should succeed
= Just (mkPromotedDataCon con name (getUnique name) prom_kind arity) = Just (mkPromotedDataCon con name (getUnique name) prom_kind roles)
| otherwise | otherwise
= Nothing = Nothing
prom_kind = promoteType (dataConUserType con) prom_kind = promoteType (dataConUserType con)
arity = dataConSourceArity con roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
map (const Representational) orig_arg_tys
eqSpecPreds :: [(TyVar,Type)] -> ThetaType eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ] eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
...@@ -996,6 +997,7 @@ dataConCannotMatch tys con ...@@ -996,6 +997,7 @@ dataConCannotMatch tys con
\begin{code} \begin{code}
buildAlgTyCon :: Name buildAlgTyCon :: Name
-> [TyVar] -- ^ Kind variables and type variables -> [TyVar] -- ^ Kind variables and type variables
-> [Role]
-> Maybe CType -> Maybe CType
-> ThetaType -- ^ Stupid theta -> ThetaType -- ^ Stupid theta
-> AlgTyConRhs -> AlgTyConRhs
...@@ -1005,14 +1007,14 @@ buildAlgTyCon :: Name ...@@ -1005,14 +1007,14 @@ buildAlgTyCon :: Name
-> TyConParent -> TyConParent
-> TyCon -> TyCon
buildAlgTyCon tc_name ktvs cType stupid_theta rhs buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
is_rec is_promotable gadt_syn parent is_rec is_promotable gadt_syn parent
= tc = tc
where where
kind = mkPiKinds ktvs liftedTypeKind kind = mkPiKinds ktvs liftedTypeKind
-- tc and mb_promoted_tc are mutually recursive -- tc and mb_promoted_tc are mutually recursive
tc = mkAlgTyCon tc_name kind ktvs cType stupid_theta tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
rhs parent is_rec gadt_syn rhs parent is_rec gadt_syn
mb_promoted_tc mb_promoted_tc
......
...@@ -547,7 +547,7 @@ mkDataConRep dflags fam_envs wrap_name data_con ...@@ -547,7 +547,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
initial_wrap_app = Var (dataConWorkId data_con) initial_wrap_app = Var (dataConWorkId data_con)
`mkTyApps` res_ty_args `mkTyApps` res_ty_args
`mkVarApps` ex_tvs `mkVarApps` ex_tvs
`mkCoApps` map (mkReflCo . snd) eq_spec `mkCoApps` map (mkReflCo Nominal . snd) eq_spec
-- Dont box the eq_spec coercions since they are -- Dont box the eq_spec coercions since they are
-- marked as HsUnpack by mk_dict_strict_mark -- marked as HsUnpack by mk_dict_strict_mark
...@@ -823,7 +823,7 @@ wrapNewTypeBody tycon args result_expr ...@@ -823,7 +823,7 @@ wrapNewTypeBody tycon args result_expr
wrapFamInstBody tycon args $ wrapFamInstBody tycon args $
mkCast result_expr (mkSymCo co) mkCast result_expr (mkSymCo co)
where where
co = mkUnbranchedAxInstCo (newTyConCo tycon) args co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args
-- When unwrapping, we do *not* apply any family coercion, because this will -- When unwrapping, we do *not* apply any family coercion, because this will
-- be done via a CoPat by the type checker. We have to do it this way as -- be done via a CoPat by the type checker. We have to do it this way as
...@@ -833,7 +833,7 @@ wrapNewTypeBody tycon args result_expr ...@@ -833,7 +833,7 @@ wrapNewTypeBody tycon args result_expr
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr unwrapNewTypeBody tycon args result_expr
= ASSERT( isNewTyCon tycon ) = ASSERT( isNewTyCon tycon )
mkCast result_expr (mkUnbranchedAxInstCo (newTyConCo tycon) args) mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args)
-- If the type constructor is a representation type of a data instance, wrap -- If the type constructor is a representation type of a data instance, wrap
-- the expression into a cast adjusting the expression type, which is an -- the expression into a cast adjusting the expression type, which is an
...@@ -843,7 +843,7 @@ unwrapNewTypeBody tycon args result_expr ...@@ -843,7 +843,7 @@ unwrapNewTypeBody tycon args result_expr
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody tycon args body wrapFamInstBody tycon args body
| Just co_con <- tyConFamilyCoercion_maybe tycon | Just co_con <- tyConFamilyCoercion_maybe tycon
= mkCast body (mkSymCo (mkUnbranchedAxInstCo co_con args)) = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args))
| otherwise | otherwise
= body = body
...@@ -851,7 +851,7 @@ wrapFamInstBody tycon args body ...@@ -851,7 +851,7 @@ wrapFamInstBody tycon args body
-- represented by a `CoAxiom`, and not a `TyCon` -- represented by a `CoAxiom`, and not a `TyCon`
wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
wrapTypeFamInstBody axiom ind args body wrapTypeFamInstBody axiom ind args body
= mkCast body (mkSymCo (mkAxInstCo axiom ind args)) = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args))
wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
wrapTypeUnbranchedFamInstBody axiom wrapTypeUnbranchedFamInstBody axiom
...@@ -860,13 +860,13 @@ wrapTypeUnbranchedFamInstBody axiom ...@@ -860,13 +860,13 @@ wrapTypeUnbranchedFamInstBody axiom
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut unwrapFamInstScrut tycon args scrut
| Just co_con <- tyConFamilyCoercion_maybe tycon | Just co_con <- tyConFamilyCoercion_maybe tycon
= mkCast scrut (mkUnbranchedAxInstCo co_con args) -- data instances only = mkCast scrut (mkUnbranchedAxInstCo Representational co_con args) -- data instances only
| otherwise | otherwise
= scrut = scrut
unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
unwrapTypeFamInstScrut axiom ind args scrut unwrapTypeFamInstScrut axiom ind args scrut
= mkCast scrut (mkAxInstCo axiom ind args) = mkCast scrut (mkAxInstCo Representational axiom ind args)
unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
unwrapTypeUnbranchedFamInstScrut axiom unwrapTypeUnbranchedFamInstScrut axiom
......
...@@ -16,6 +16,11 @@ module SMRep ( ...@@ -16,6 +16,11 @@ module SMRep (
WordOff, ByteOff, WordOff, ByteOff,
roundUpToWords, roundUpToWords,
#if __GLASGOW_HASKELL__ > 706
-- ** Immutable arrays of StgWords
UArrayStgWord, listArray, toByteArray,
#endif
-- * Closure repesentation -- * Closure repesentation
SMRep(..), -- CmmInfo sees the rep; no one else does SMRep(..), -- CmmInfo sees the rep; no one else does
IsStatic, IsStatic,
...@@ -49,8 +54,13 @@ import DynFlags ...@@ -49,8 +54,13 @@ import DynFlags
import Outputable import Outputable
import Platform import Platform
import FastString import FastString
import qualified Data.Array.Base as Array
#if __GLASGOW_HASKELL__ > 706
import GHC.Base ( ByteArray# )
import Data.Ix
#endif
import Data.Array.Base
import Data.Char( ord ) import Data.Char( ord )
import Data.Word import Data.Word
import Data.Bits import Data.Bits
...@@ -80,7 +90,11 @@ newtype StgWord = StgWord Word64 ...@@ -80,7 +90,11 @@ newtype StgWord = StgWord Word64
#if __GLASGOW_HASKELL__ < 706 #if __GLASGOW_HASKELL__ < 706
Num, Num,
#endif #endif
Bits, IArray UArray)
#if __GLASGOW_HASKELL__ <= 706
Array.IArray Array.UArray,
#endif
Bits)
fromStgWord :: StgWord -> Integer fromStgWord :: StgWord -> Integer
fromStgWord (StgWord i) = toInteger i fromStgWord (StgWord i) = toInteger i
...@@ -125,6 +139,30 @@ hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int ...@@ -125,6 +139,30 @@ hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int
hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2 hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2
\end{code} \end{code}
%************************************************************************
%* *
Immutable arrays of StgWords
%* *
%************************************************************************
\begin{code}
#if __GLASGOW_HASKELL__ > 706
-- TODO: Improve with newtype coercions!
newtype UArrayStgWord i = UArrayStgWord (Array.UArray i Word64)
listArray :: Ix i => (i, i) -> [StgWord] -> UArrayStgWord i
listArray (i,j) words
= UArrayStgWord $ Array.listArray (i,j) (map unStgWord words)
where unStgWord (StgWord w64) = w64
toByteArray :: UArrayStgWord i -> ByteArray#
toByteArray (UArrayStgWord (Array.UArray _ _ _ b)) = b
#endif
\end{code}
%************************************************************************ %************************************************************************
%* * %* *
......
...@@ -24,7 +24,6 @@ import Demand ...@@ -24,7 +24,6 @@ import Demand
import CoreSyn import CoreSyn
import CoreFVs import CoreFVs
import CoreUtils import CoreUtils
import Pair
import Bag import Bag
import Literal import Literal
import DataCon import DataCon
...@@ -306,7 +305,8 @@ lintCoreExpr (Lit lit) ...@@ -306,7 +305,8 @@ lintCoreExpr (Lit lit)
lintCoreExpr (Cast expr co) lintCoreExpr (Cast expr co)
= do { expr_ty <- lintCoreExpr expr = do { expr_ty <- lintCoreExpr expr
; co' <- applySubstCo co ; co' <- applySubstCo co
; (_, from_ty, to_ty) <- lintCoercion co' ; (_, from_ty, to_ty, r) <- lintCoercion co'
; checkRole co' Representational r
; checkTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) ; checkTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
; return to_ty } ; return to_ty }
...@@ -400,9 +400,9 @@ lintCoreExpr (Type ty) ...@@ -400,9 +400,9 @@ lintCoreExpr (Type ty)
= pprPanic "lintCoreExpr" (ppr ty) = pprPanic "lintCoreExpr" (ppr ty)
lintCoreExpr (Coercion co) lintCoreExpr (Coercion co)
= do { co' <- lintInCo co = do { (_kind, ty1, ty2, role) <- lintInCo co
; let Pair ty1 ty2 = coercionKind co' ; checkRole co Nominal role
; return (mkCoercionType ty1 ty2) } ; return (mkCoercionType role ty1 ty2) }
\end{code} \end{code}
...@@ -804,49 +804,56 @@ lint_app doc kfn kas ...@@ -804,49 +804,56 @@ lint_app doc kfn kas
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
lintInCo :: InCoercion -> LintM OutCoercion lintInCo :: InCoercion -> LintM (LintedKind, LintedType, LintedType, Role)
-- Check the coercion, and apply the substitution to it -- Check the coercion, and apply the substitution to it
-- See Note [Linting type lets] -- See Note [Linting type lets]
lintInCo co lintInCo co
= addLoc (InCo co) $ = addLoc (InCo co) $
do { co' <- applySubstCo co do { co' <- applySubstCo co
; _ <- lintCoercion co' ; lintCoercion co' }
; return co' }
lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType) lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType, Role)
-- Check the kind of a coercion term, returning the kind -- Check the kind of a coercion term, returning the kind
-- Post-condition: the returned OutTypes are lint-free -- Post-condition: the returned OutTypes are lint-free
-- and have the same kind as each other -- and have the same kind as each other
-- If you edit this function, you may need to update the GHC formalism -- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism] -- See Note [GHC Formalism]
lintCoercion (Refl ty) lintCoercion (Refl r ty)
= do { k <- lintType ty = do { k <- lintType ty
; return (k, ty, ty) } ; return (k, ty, ty, r) }
lintCoercion co@(TyConAppCo tc cos) lintCoercion co@(TyConAppCo r tc cos)
| tc `hasKey` funTyConKey | tc `hasKey` funTyConKey
, [co1,co2] <- cos , [co1,co2] <- cos
= do { (k1,s1,t1) <- lintCoercion co1 = do { (k1,s1,t1,r1) <- lintCoercion co1
; (k2,s2,t2) <- lintCoercion co2 ; (k2,s2,t2,r2) <- lintCoercion co2
; rk <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2 ; rk <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2
; return (rk, mkFunTy s1 s2, mkFunTy t1 t2) } ; checkRole co1 r r1
; checkRole co2 r r2
; return (rk, mkFunTy s1 s2, mkFunTy t1 t2, r) }
| otherwise | otherwise
= do { (ks,ss,ts) <- mapAndUnzip3M lintCoercion cos = do { (ks,ss,ts,rs) <- mapAndUnzip4M lintCoercion cos
; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks) ; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks)
; return (rk, mkTyConApp tc ss, mkTyConApp tc ts) } ; _ <- zipWith3M checkRole cos (tyConRolesX r tc) rs
; return (rk, mkTyConApp tc ss, mkTyConApp tc ts, r) }
lintCoercion co@(AppCo co1 co2) lintCoercion co@(AppCo co1 co2)
= do { (k1,s1,t1) <- lintCoercion co1 = do { (k1,s1,t1,r1) <- lintCoercion co1
; (k2,s2,t2) <- lintCoercion co2 ; (k2,s2,t2,r2) <- lintCoercion co2
; rk <- lint_co_app co k1 [(s2,k2)] ; rk <- lint_co_app co k1 [(s2,k2)]
; return (rk, mkAppTy s1 s2, mkAppTy t1 t2) } ; if r1 == Phantom
then checkL (r2 == Phantom || r2 == Nominal)
(ptext (sLit "Second argument in AppCo cannot be R:") $$
ppr co)
else checkRole co Nominal r2
; return (rk, mkAppTy s1 s2, mkAppTy t1 t2, r1) }
lintCoercion (ForAllCo tv co) lintCoercion (ForAllCo tv co)
= do { lintTyBndrKind tv = do { lintTyBndrKind tv
; (k, s, t) <- addInScopeVar tv (lintCoercion co) ; (k, s, t, r) <- addInScopeVar tv (lintCoercion co)
; return (k, mkForAllTy tv s, mkForAllTy tv t) } ; return (k, mkForAllTy tv s, mkForAllTy tv t, r) }
lintCoercion (CoVarCo cv) lintCoercion (CoVarCo cv)
| not (isCoVar cv) | not (isCoVar cv)
...@@ -857,52 +864,58 @@ lintCoercion (CoVarCo cv) ...@@ -857,52 +864,58 @@ lintCoercion (CoVarCo cv)
; cv' <- lookupIdInScope cv ; cv' <- lookupIdInScope cv
; let (s,t) = coVarKind cv' ; let (s,t) = coVarKind cv'
k = typeKind s k = typeKind s
r = coVarRole cv'
; when (isSuperKind k) $ ; when (isSuperKind k) $
checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality")) do { checkL (r == Nominal) (hang (ptext (sLit "Non-nominal kind equality"))
2 (ppr cv)) 2 (ppr cv))
; return (k, s, t) } ; checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality"))
2 (ppr cv)) }
; return (k, s, t, r) }
lintCoercion (UnsafeCo ty1 ty2) lintCoercion (UnivCo r ty1 ty2)
= do { k1 <- lintType ty1 = do { k1 <- lintType ty1
; _k2 <- lintType ty2 ; _k2 <- lintType ty2
-- ; unless (k1 `eqKind` k2) $ -- ; unless (k1 `eqKind` k2) $
-- failWithL (hang (ptext (sLit "Unsafe coercion changes kind")) -- failWithL (hang (ptext (sLit "Unsafe coercion changes kind"))
-- 2 (ppr co)) -- 2 (ppr co))
; return (k1, ty1, ty2) } ; return (k1, ty1, ty2, r) }
lintCoercion (SymCo co) lintCoercion (SymCo co)
= do { (k, ty1, ty2) <- lintCoercion co = do { (k, ty1, ty2, r) <- lintCoercion co
; return (k, ty2, ty1) } ; return (k, ty2, ty1, r) }
lintCoercion co@(TransCo co1 co2) lintCoercion co@(TransCo co1 co2)
= do { (k1, ty1a, ty1b) <- lintCoercion co1 = do { (k1, ty1a, ty1b, r1) <- lintCoercion co1
; (_, ty2a, ty2b) <- lintCoercion co2 ; (_, ty2a, ty2b, r2) <- lintCoercion co2
; checkL (ty1b `eqType` ty2a) ; checkL (ty1b `eqType` ty2a)
(hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co) (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co)
2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
; return (k1, ty1a, ty2b) } ; checkRole co r1 r2
; return (k1, ty1a, ty2b, r1) }
lintCoercion the_co@(NthCo n co) lintCoercion the_co@(NthCo n co)
= do { (_,s,t) <- lintCoercion co = do { (_,s,t,r) <- lintCoercion co
; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of ; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of
(Just (tc_s, tys_s), Just (tc_t, tys_t)) (Just (tc_s, tys_s), Just (tc_t, tys_t))
| tc_s == tc_t | tc_s == tc_t
, tys_s `equalLength` tys_t , tys_s `equalLength` tys_t
, n < length tys_s , n < length tys_s
-> return (ks, ts, tt) -> return (ks, ts, tt, tr)
where where
ts = getNth tys_s n ts = getNth tys_s n
tt = getNth tys_t n tt = getNth tys_t n
tr = nthRole r tc_s n
ks = typeKind ts ks = typeKind ts
_ -> failWithL (hang (ptext (sLit "Bad getNth:")) _ -> failWithL (hang (ptext (sLit "Bad getNth:"))
2 (ppr the_co $$ ppr s $$ ppr t)) } 2 (ppr the_co $$ ppr s $$ ppr t)) }
lintCoercion the_co@(LRCo lr co) lintCoercion the_co@(LRCo lr co)
= do { (_,s,t) <- lintCoercion co = do { (_,s,t,r) <- lintCoercion co
; checkRole co Nominal r
; case (splitAppTy_maybe s, splitAppTy_maybe t) of ; case (splitAppTy_maybe s, splitAppTy_maybe t) of
(Just s_pr, Just t_pr) (Just s_pr, Just t_pr)
-> return (k, s_pick, t_pick) -> return (k, s_pick, t_pick, Nominal)
where where
s_pick = pickLR lr s_pr s_pick = pickLR lr s_pr
t_pick = pickLR lr t_pr t_pick = pickLR lr t_pr
...@@ -912,13 +925,13 @@ lintCoercion the_co@(LRCo lr co) ...@@ -912,13 +925,13 @@ lintCoercion the_co@(LRCo lr co)
2 (ppr the_co $$ ppr s $$ ppr t)) } 2 (ppr the_co $$ ppr s $$ ppr t)) }
lintCoercion (InstCo co arg_ty) lintCoercion (InstCo co arg_ty)
= do { (k,s,t) <- lintCoercion co = do { (k,s,t,r) <- lintCoercion co
; arg_kind <- lintType arg_ty ; arg_kind <- lintType arg_ty
; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of
(Just (tv1,ty1), Just (tv2,ty2)) (Just (tv1,ty1), Just (tv2,ty2))
| arg_kind `isSubKind` tyVarKind tv1 | arg_kind `isSubKind` tyVarKind tv1
-> return (k, substTyWith [tv1] [arg_ty] ty1, -> return (k, substTyWith [tv1] [arg_ty] ty1,
substTyWith [tv2] [arg_ty] ty2) substTyWith [tv2] [arg_ty] ty2, r)
| otherwise | otherwise
-> failWithL (ptext (sLit "Kind mis-match in inst coercion")) -> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
_ -> failWithL (ptext (sLit "Bad argument of inst")) } _ -> failWithL (ptext (sLit "Bad argument of inst")) }
...@@ -927,27 +940,29 @@ lintCoercion co@(AxiomInstCo con ind cos) ...@@ -927,27 +940,29 @@ lintCoercion co@(AxiomInstCo con ind cos)
= do { unless (0 <= ind && ind < brListLength (coAxiomBranches con)) = do { unless (0 <= ind && ind < brListLength (coAxiomBranches con))
(bad_ax (ptext (sLit "index out of range"))) (bad_ax (ptext (sLit "index out of range")))
-- See Note [Kind instantiation in coercions] -- See Note [Kind instantiation in coercions]
; let CoAxBranch { cab_tvs = ktvs ; let CoAxBranch { cab_tvs = ktvs
, cab_lhs = lhs , cab_roles = roles
, cab_rhs = rhs } = coAxiomNthBranch con ind , cab_lhs = lhs
, cab_rhs = rhs } = coAxiomNthBranch con ind
; unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths"))) ; unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths")))
; in_scope <- getInScope ; in_scope <- getInScope
; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv ; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv
; (subst_l, subst_r) <- foldlM check_ki ; (subst_l, subst_r) <- foldlM check_ki
(empty_subst, empty_subst) (empty_subst, empty_subst)
(ktvs `zip` cos) (zip3 ktvs roles cos)
; let lhs' = Type.substTys subst_l lhs ; let lhs' = Type.substTys subst_l lhs
rhs' = Type.substTy subst_r rhs rhs' = Type.substTy subst_r rhs
; case checkAxInstCo co of ; case checkAxInstCo co of
Just bad_branch -> bad_ax $ ptext (sLit "inconsistent with") <+> (pprCoAxBranch (coAxiomTyCon con) bad_branch) Just bad_branch -> bad_ax $ ptext (sLit "inconsistent with") <+> (pprCoAxBranch (coAxiomTyCon con) bad_branch)
Nothing -> return () Nothing -> return ()
; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs') } ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs', coAxiomRole con) }
where where
bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what) bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what)
2 (ppr co)) 2 (ppr co))
check_ki (subst_l, subst_r) (ktv, co) check_ki (subst_l, subst_r) (ktv, role, co)
= do { (k, t1, t2) <- lintCoercion co = do { (k, t1, t2, r) <- lintCoercion co
; checkRole co role r
; let ktv_kind = Type.substTy subst_l (tyVarKind ktv) ; let ktv_kind = Type.substTy subst_l (tyVarKind ktv)
-- Using subst_l is ok, because subst_l and subst_r -- Using subst_l is ok, because subst_l and subst_r
-- must agree on kind equalities -- must agree on kind equalities
...@@ -955,6 +970,11 @@ lintCoercion co@(AxiomInstCo con ind cos) ...@@ -955,6 +970,11 @@ lintCoercion co@(AxiomInstCo con ind cos)
(bad_ax (ptext (sLit "check_ki2") <+> vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] )) (bad_ax (ptext (sLit "check_ki2") <+> vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] ))
; return (Type.extendTvSubst subst_l ktv t1, ; return (Type.extendTvSubst subst_l ktv t1,
Type.extendTvSubst subst_r ktv t2) } Type.extendTvSubst subst_r ktv t2) }
lintCoercion co@(SubCo co')
= do { (k,s,t,r) <- lintCoercion co'
; checkRole co Nominal r
; return (k,s,t,Representational) }
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -1131,6 +1151,17 @@ checkTys :: OutType -> OutType -> MsgDoc -> LintM () ...@@ -1131,6 +1151,17 @@ checkTys :: OutType -> OutType -> MsgDoc -> LintM ()
-- annotations need only be consistent, not equal) -- annotations need only be consistent, not equal)
-- Assumes ty1,ty2 are have alrady had the substitution applied -- Assumes ty1,ty2 are have alrady had the substitution applied
checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
checkRole :: Coercion
-> Role -- expected
-> Role -- actual
-> LintM ()
checkRole co r1 r2
= checkL (r1 == r2)
(ptext (sLit "Role incompatibility: expected") <+> ppr r1 <> comma <+>
ptext (sLit "got") <+> ppr r2 $$
ptext (sLit "in") <+> ppr co)
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -1163,7 +1163,7 @@ data ConCont = CC [CoreExpr] Coercion ...@@ -1163,7 +1163,7 @@ data ConCont = CC [CoreExpr] Coercion
-- where t1..tk are the *universally-qantified* type args of 'dc' -- where t1..tk are the *universally-qantified* type args of 'dc'
exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
exprIsConApp_maybe (in_scope, id_unf) expr exprIsConApp_maybe (in_scope, id_unf) expr
= go (Left in_scope) expr (CC [] (mkReflCo (exprType expr))) = go (Left in_scope) expr (CC [] (mkReflCo Representational (exprType expr)))
where where
go :: Either InScopeSet Subst go :: Either InScopeSet Subst
-> CoreExpr -> ConCont -> CoreExpr -> ConCont
...@@ -1252,9 +1252,11 @@ dealWithCoercion co dc dc_args ...@@ -1252,9 +1252,11 @@ dealWithCoercion co dc dc_args
-- Make the "theta" from Fig 3 of the paper -- Make the "theta" from Fig 3 of the paper
gammas = decomposeCo tc_arity co gammas = decomposeCo tc_arity co
theta_subst = liftCoSubstWith theta_subst = liftCoSubstWith Representational
(dc_univ_tyvars ++ dc_ex_tyvars) (dc_univ_tyvars ++ dc_ex_tyvars)
(gammas ++ map mkReflCo (stripTypeArgs ex_args)) -- existentials are at role N
(gammas ++ map (mkReflCo Nominal)
(stripTypeArgs ex_args))
-- Cast the value arguments (which include dictionaries) -- Cast the value arguments (which include dictionaries)
new_val_args = zipWith cast_arg arg_tys val_args new_val_args = zipWith cast_arg arg_tys val_args
......
...@@ -187,9 +187,12 @@ mkCast (Coercion e_co) co ...@@ -187,9 +187,12 @@ mkCast (Coercion e_co) co
= Coercion (mkCoCast e_co co) = Coercion (mkCoCast e_co co)
mkCast (Cast expr co2) co mkCast (Cast expr co2) co
= ASSERT(let { Pair from_ty _to_ty = coercionKind co; = WARN(let { Pair from_ty _to_ty = coercionKind co;
Pair _from_ty2 to_ty2 = coercionKind co2} in Pair _from_ty2 to_ty2 = coercionKind co2} in
from_ty `eqType` to_ty2 ) not (from_ty `eqType` to_ty2),