summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/basicTypes/DataCon.lhs10
-rw-r--r--compiler/basicTypes/MkId.lhs14
-rw-r--r--compiler/cmm/SMRep.lhs42
-rw-r--r--compiler/coreSyn/CoreLint.lhs123
-rw-r--r--compiler/coreSyn/CoreSubst.lhs8
-rw-r--r--compiler/coreSyn/CoreUtils.lhs16
-rw-r--r--compiler/coreSyn/ExternalCore.lhs29
-rw-r--r--compiler/coreSyn/MkExternalCore.lhs24
-rw-r--r--compiler/coreSyn/PprExternalCore.lhs60
-rw-r--r--compiler/coreSyn/TrieMap.lhs82
-rw-r--r--compiler/deSugar/DsBinds.lhs59
-rw-r--r--compiler/deSugar/DsForeign.lhs2
-rw-r--r--compiler/deSugar/DsMeta.hs106
-rw-r--r--compiler/ghci/ByteCodeAsm.lhs16
-rw-r--r--compiler/hsSyn/Convert.lhs19
-rw-r--r--compiler/hsSyn/HsTypes.lhs25
-rw-r--r--compiler/hsSyn/HsUtils.lhs2
-rw-r--r--compiler/iface/BinIface.hs1
-rw-r--r--compiler/iface/BuildTyCl.lhs43
-rw-r--r--compiler/iface/IfaceSyn.lhs128
-rw-r--r--compiler/iface/IfaceType.lhs343
-rw-r--r--compiler/iface/MkIface.lhs19
-rw-r--r--compiler/iface/TcIface.lhs75
-rw-r--r--compiler/main/DynFlags.hs2
-rw-r--r--compiler/parser/Lexer.x31
-rw-r--r--compiler/parser/Parser.y.pp26
-rw-r--r--compiler/parser/ParserCore.y7
-rw-r--r--compiler/parser/RdrHsSyn.lhs8
-rw-r--r--compiler/prelude/PrelNames.lhs4
-rw-r--r--compiler/prelude/PrelRules.lhs4
-rw-r--r--compiler/prelude/TysPrim.lhs62
-rw-r--r--compiler/prelude/TysWiredIn.lhs4
-rw-r--r--compiler/rename/RnTypes.lhs43
-rw-r--r--compiler/simplCore/SimplUtils.lhs2
-rw-r--r--compiler/specialise/Rules.lhs7
-rw-r--r--compiler/specialise/SpecConstr.lhs2
-rw-r--r--compiler/stranal/WwLib.lhs4
-rw-r--r--compiler/typecheck/TcDeriv.lhs16
-rw-r--r--compiler/typecheck/TcEvidence.lhs8
-rw-r--r--compiler/typecheck/TcForeign.lhs48
-rw-r--r--compiler/typecheck/TcGenGenerics.lhs2
-rw-r--r--compiler/typecheck/TcHsType.lhs105
-rw-r--r--compiler/typecheck/TcInstDcls.lhs13
-rw-r--r--compiler/typecheck/TcInteract.lhs3
-rw-r--r--compiler/typecheck/TcRnDriver.lhs12
-rw-r--r--compiler/typecheck/TcSplice.lhs42
-rw-r--r--compiler/typecheck/TcTyClsDecls.lhs302
-rw-r--r--compiler/typecheck/TcTyDecls.lhs293
-rw-r--r--compiler/typecheck/TcType.lhs7
-rw-r--r--compiler/types/Class.lhs6
-rw-r--r--compiler/types/CoAxiom.lhs82
-rw-r--r--compiler/types/Coercion.lhs802
-rw-r--r--compiler/types/FamInstEnv.lhs78
-rw-r--r--compiler/types/OptCoercion.lhs199
-rw-r--r--compiler/types/TyCon.lhs110
-rw-r--r--compiler/types/Type.lhs9
-rw-r--r--compiler/types/TypeRep.lhs2
-rw-r--r--compiler/utils/Maybes.lhs5
-rw-r--r--compiler/utils/UniqFM.lhs2
-rw-r--r--compiler/utils/Util.lhs10
-rw-r--r--compiler/vectorise/Vectorise/Generic/PAMethods.hs8
-rw-r--r--compiler/vectorise/Vectorise/Generic/PData.hs1
-rw-r--r--compiler/vectorise/Vectorise/Type/Env.hs2
-rw-r--r--compiler/vectorise/Vectorise/Type/TyConDecl.hs2
-rw-r--r--compiler/vectorise/Vectorise/Utils/Base.hs4
-rw-r--r--compiler/vectorise/Vectorise/Utils/PADict.hs2
-rw-r--r--docs/core-spec/CoreLint.ott178
-rw-r--r--docs/core-spec/CoreSyn.ott77
-rw-r--r--docs/core-spec/OpSem.ott2
-rw-r--r--docs/core-spec/README2
-rw-r--r--docs/core-spec/core-spec.mng54
-rw-r--r--docs/core-spec/core-spec.pdfbin349150 -> 359837 bytes
-rw-r--r--docs/users_guide/glasgow_exts.xml211
73 files changed, 3091 insertions, 1060 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 42032d49a8..eba5c8b67d 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -650,11 +650,12 @@ mkDataCon name declared_infix
| isJust (promotableTyCon_maybe rep_tycon)
-- The TyCon is promotable only if all its datacons
-- 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
= Nothing
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 spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
@@ -996,6 +997,7 @@ dataConCannotMatch tys con
\begin{code}
buildAlgTyCon :: Name
-> [TyVar] -- ^ Kind variables and type variables
+ -> [Role]
-> Maybe CType
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
@@ -1005,14 +1007,14 @@ buildAlgTyCon :: Name
-> TyConParent
-> 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
= tc
where
kind = mkPiKinds ktvs liftedTypeKind
-- 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
mb_promoted_tc
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 218033a4cf..14e29c1d99 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -547,7 +547,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
initial_wrap_app = Var (dataConWorkId data_con)
`mkTyApps` res_ty_args
`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
-- marked as HsUnpack by mk_dict_strict_mark
@@ -823,7 +823,7 @@ wrapNewTypeBody tycon args result_expr
wrapFamInstBody tycon args $
mkCast result_expr (mkSymCo co)
where
- co = mkUnbranchedAxInstCo (newTyConCo tycon) args
+ co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args
-- 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
@@ -833,7 +833,7 @@ wrapNewTypeBody tycon args result_expr
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
= 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
-- the expression into a cast adjusting the expression type, which is an
@@ -843,7 +843,7 @@ unwrapNewTypeBody tycon args result_expr
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody tycon args body
| Just co_con <- tyConFamilyCoercion_maybe tycon
- = mkCast body (mkSymCo (mkUnbranchedAxInstCo co_con args))
+ = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args))
| otherwise
= body
@@ -851,7 +851,7 @@ wrapFamInstBody tycon args body
-- represented by a `CoAxiom`, and not a `TyCon`
wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
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 axiom
@@ -860,13 +860,13 @@ wrapTypeUnbranchedFamInstBody axiom
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut
| 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
= scrut
unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
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 axiom
diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs
index 6f569ef6fa..c54f6d5f9d 100644
--- a/compiler/cmm/SMRep.lhs
+++ b/compiler/cmm/SMRep.lhs
@@ -16,6 +16,11 @@ module SMRep (
WordOff, ByteOff,
roundUpToWords,
+#if __GLASGOW_HASKELL__ > 706
+ -- ** Immutable arrays of StgWords
+ UArrayStgWord, listArray, toByteArray,
+#endif
+
-- * Closure repesentation
SMRep(..), -- CmmInfo sees the rep; no one else does
IsStatic,
@@ -49,8 +54,13 @@ import DynFlags
import Outputable
import Platform
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.Word
import Data.Bits
@@ -80,7 +90,11 @@ newtype StgWord = StgWord Word64
#if __GLASGOW_HASKELL__ < 706
Num,
#endif
- Bits, IArray UArray)
+
+#if __GLASGOW_HASKELL__ <= 706
+ Array.IArray Array.UArray,
+#endif
+ Bits)
fromStgWord :: StgWord -> Integer
fromStgWord (StgWord i) = toInteger i
@@ -125,6 +139,30 @@ hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int
hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2
\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}
%************************************************************************
%* *
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index f9256e18ad..5befacdd45 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -24,7 +24,6 @@ import Demand
import CoreSyn
import CoreFVs
import CoreUtils
-import Pair
import Bag
import Literal
import DataCon
@@ -306,7 +305,8 @@ lintCoreExpr (Lit lit)
lintCoreExpr (Cast expr co)
= do { expr_ty <- lintCoreExpr expr
; 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)
; return to_ty }
@@ -400,9 +400,9 @@ lintCoreExpr (Type ty)
= pprPanic "lintCoreExpr" (ppr ty)
lintCoreExpr (Coercion co)
- = do { co' <- lintInCo co
- ; let Pair ty1 ty2 = coercionKind co'
- ; return (mkCoercionType ty1 ty2) }
+ = do { (_kind, ty1, ty2, role) <- lintInCo co
+ ; checkRole co Nominal role
+ ; return (mkCoercionType role ty1 ty2) }
\end{code}
@@ -804,49 +804,56 @@ lint_app doc kfn kas
%************************************************************************
\begin{code}
-lintInCo :: InCoercion -> LintM OutCoercion
+lintInCo :: InCoercion -> LintM (LintedKind, LintedType, LintedType, Role)
-- Check the coercion, and apply the substitution to it
-- See Note [Linting type lets]
lintInCo co
= addLoc (InCo co) $
do { co' <- applySubstCo co
- ; _ <- lintCoercion co'
- ; return co' }
+ ; lintCoercion co' }
-lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType)
+lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType, Role)
-- Check the kind of a coercion term, returning the kind
-- Post-condition: the returned OutTypes are lint-free
-- and have the same kind as each other
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
-lintCoercion (Refl ty)
+lintCoercion (Refl r 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
, [co1,co2] <- cos
- = do { (k1,s1,t1) <- lintCoercion co1
- ; (k2,s2,t2) <- lintCoercion co2
+ = do { (k1,s1,t1,r1) <- lintCoercion co1
+ ; (k2,s2,t2,r2) <- lintCoercion co2
; 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
- = 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)
- ; 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)
- = do { (k1,s1,t1) <- lintCoercion co1
- ; (k2,s2,t2) <- lintCoercion co2
+ = do { (k1,s1,t1,r1) <- lintCoercion co1
+ ; (k2,s2,t2,r2) <- lintCoercion co2
; 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)
= do { lintTyBndrKind tv
- ; (k, s, t) <- addInScopeVar tv (lintCoercion co)
- ; return (k, mkForAllTy tv s, mkForAllTy tv t) }
+ ; (k, s, t, r) <- addInScopeVar tv (lintCoercion co)
+ ; return (k, mkForAllTy tv s, mkForAllTy tv t, r) }
lintCoercion (CoVarCo cv)
| not (isCoVar cv)
@@ -857,52 +864,58 @@ lintCoercion (CoVarCo cv)
; cv' <- lookupIdInScope cv
; let (s,t) = coVarKind cv'
k = typeKind s
+ r = coVarRole cv'
; when (isSuperKind k) $
- checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality"))
- 2 (ppr cv))
- ; return (k, s, t) }
+ do { checkL (r == Nominal) (hang (ptext (sLit "Non-nominal kind equality"))
+ 2 (ppr cv))
+ ; 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
; _k2 <- lintType ty2
-- ; unless (k1 `eqKind` k2) $
-- failWithL (hang (ptext (sLit "Unsafe coercion changes kind"))
-- 2 (ppr co))
- ; return (k1, ty1, ty2) }
+ ; return (k1, ty1, ty2, r) }
lintCoercion (SymCo co)
- = do { (k, ty1, ty2) <- lintCoercion co
- ; return (k, ty2, ty1) }
+ = do { (k, ty1, ty2, r) <- lintCoercion co
+ ; return (k, ty2, ty1, r) }
lintCoercion co@(TransCo co1 co2)
- = do { (k1, ty1a, ty1b) <- lintCoercion co1
- ; (_, ty2a, ty2b) <- lintCoercion co2
+ = do { (k1, ty1a, ty1b, r1) <- lintCoercion co1
+ ; (_, ty2a, ty2b, r2) <- lintCoercion co2
; checkL (ty1b `eqType` ty2a)
(hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co)
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)
- = do { (_,s,t) <- lintCoercion co
+ = do { (_,s,t,r) <- lintCoercion co
; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of
(Just (tc_s, tys_s), Just (tc_t, tys_t))
| tc_s == tc_t
, tys_s `equalLength` tys_t
, n < length tys_s
- -> return (ks, ts, tt)
+ -> return (ks, ts, tt, tr)
where
ts = getNth tys_s n
tt = getNth tys_t n
+ tr = nthRole r tc_s n
ks = typeKind ts
_ -> failWithL (hang (ptext (sLit "Bad getNth:"))
2 (ppr the_co $$ ppr s $$ ppr t)) }
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
(Just s_pr, Just t_pr)
- -> return (k, s_pick, t_pick)
+ -> return (k, s_pick, t_pick, Nominal)
where
s_pick = pickLR lr s_pr
t_pick = pickLR lr t_pr
@@ -912,13 +925,13 @@ lintCoercion the_co@(LRCo lr co)
2 (ppr the_co $$ ppr s $$ ppr t)) }
lintCoercion (InstCo co arg_ty)
- = do { (k,s,t) <- lintCoercion co
- ; arg_kind <- lintType arg_ty
+ = do { (k,s,t,r) <- lintCoercion co
+ ; arg_kind <- lintType arg_ty
; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of
(Just (tv1,ty1), Just (tv2,ty2))
| arg_kind `isSubKind` tyVarKind tv1
-> return (k, substTyWith [tv1] [arg_ty] ty1,
- substTyWith [tv2] [arg_ty] ty2)
+ substTyWith [tv2] [arg_ty] ty2, r)
| otherwise
-> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
_ -> failWithL (ptext (sLit "Bad argument of inst")) }
@@ -927,27 +940,29 @@ lintCoercion co@(AxiomInstCo con ind cos)
= do { unless (0 <= ind && ind < brListLength (coAxiomBranches con))
(bad_ax (ptext (sLit "index out of range")))
-- See Note [Kind instantiation in coercions]
- ; let CoAxBranch { cab_tvs = ktvs
- , cab_lhs = lhs
- , cab_rhs = rhs } = coAxiomNthBranch con ind
+ ; let CoAxBranch { cab_tvs = ktvs
+ , cab_roles = roles
+ , cab_lhs = lhs
+ , cab_rhs = rhs } = coAxiomNthBranch con ind
; unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths")))
; in_scope <- getInScope
; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv
; (subst_l, subst_r) <- foldlM check_ki
(empty_subst, empty_subst)
- (ktvs `zip` cos)
+ (zip3 ktvs roles cos)
; let lhs' = Type.substTys subst_l lhs
rhs' = Type.substTy subst_r rhs
; case checkAxInstCo co of
Just bad_branch -> bad_ax $ ptext (sLit "inconsistent with") <+> (pprCoAxBranch (coAxiomTyCon con) bad_branch)
Nothing -> return ()
- ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs') }
+ ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs', coAxiomRole con) }
where
bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what)
2 (ppr co))
- check_ki (subst_l, subst_r) (ktv, co)
- = do { (k, t1, t2) <- lintCoercion co
+ check_ki (subst_l, subst_r) (ktv, role, co)
+ = do { (k, t1, t2, r) <- lintCoercion co
+ ; checkRole co role r
; let ktv_kind = Type.substTy subst_l (tyVarKind ktv)
-- Using subst_l is ok, because subst_l and subst_r
-- must agree on kind equalities
@@ -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 ] ))
; return (Type.extendTvSubst subst_l ktv t1,
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}
%************************************************************************
@@ -1131,6 +1151,17 @@ checkTys :: OutType -> OutType -> MsgDoc -> LintM ()
-- annotations need only be consistent, not equal)
-- Assumes ty1,ty2 are have alrady had the substitution applied
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}
%************************************************************************
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index bc9c767d29..25a751b423 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -1163,7 +1163,7 @@ data ConCont = CC [CoreExpr] Coercion
-- where t1..tk are the *universally-qantified* type args of 'dc'
exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
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
go :: Either InScopeSet Subst
-> CoreExpr -> ConCont
@@ -1252,9 +1252,11 @@ dealWithCoercion co dc dc_args
-- Make the "theta" from Fig 3 of the paper
gammas = decomposeCo tc_arity co
- theta_subst = liftCoSubstWith
+ theta_subst = liftCoSubstWith Representational
(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)
new_val_args = zipWith cast_arg arg_tys val_args
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 00f704f7c8..c872ac311e 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -187,9 +187,12 @@ mkCast (Coercion e_co) co
= Coercion (mkCoCast e_co co)
mkCast (Cast expr co2) co
- = ASSERT(let { Pair from_ty _to_ty = coercionKind co;
- Pair _from_ty2 to_ty2 = coercionKind co2} in
- from_ty `eqType` to_ty2 )
+ = WARN(let { Pair from_ty _to_ty = coercionKind co;
+ Pair _from_ty2 to_ty2 = coercionKind co2} in
+ not (from_ty `eqType` to_ty2),
+ vcat ([ ptext (sLit "expr:") <+> ppr expr
+ , ptext (sLit "co2:") <+> ppr co2
+ , ptext (sLit "co:") <+> ppr co ]) )
mkCast expr (mkTransCo co2 co)
mkCast expr co
@@ -1602,7 +1605,7 @@ need to address that here.
\begin{code}
tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
tryEtaReduce bndrs body
- = go (reverse bndrs) body (mkReflCo (exprType body))
+ = go (reverse bndrs) body (mkReflCo Representational (exprType body))
where
incoming_arity = count isId bndrs
@@ -1659,9 +1662,10 @@ tryEtaReduce bndrs body
| Just tv <- getTyVar_maybe ty
, bndr == tv = Just (mkForAllCo tv co)
ok_arg bndr (Var v) co
- | bndr == v = Just (mkFunCo (mkReflCo (idType bndr)) co)
+ | bndr == v = Just (mkFunCo Representational
+ (mkReflCo Representational (idType bndr)) co)
ok_arg bndr (Cast (Var v) co_arg) co
- | bndr == v = Just (mkFunCo (mkSymCo co_arg) co)
+ | bndr == v = Just (mkFunCo Representational (mkSymCo co_arg) co)
-- The simplifier combines multiple casts into one,
-- so we can have a simple-minded pattern match here
ok_arg _ _ _ = Nothing
diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs
index f002c3a3e5..ecc24b1155 100644
--- a/compiler/coreSyn/ExternalCore.lhs
+++ b/compiler/coreSyn/ExternalCore.lhs
@@ -34,7 +34,7 @@ data Exp
| Lam Bind Exp
| Let Vdefg Exp
| Case Exp Vbind Ty [Alt] {- non-empty list -}
- | Cast Exp Ty
+ | Cast Exp Coercion
| Tick String Exp {- XXX probably wrong -}
| External String String Ty {- target name, convention, and type -}
| DynExternal String Ty {- convention and type (incl. Addr# of target as first arg) -}
@@ -52,23 +52,30 @@ data Alt
type Vbind = (Var,Ty)
type Tbind = (Tvar,Kind)
--- Internally, we represent types and coercions separately; but for
--- the purposes of external core (at least for now) it's still
--- convenient to collapse them into a single type.
data Ty
= Tvar Tvar
| Tcon (Qual Tcon)
| Tapp Ty Ty
| Tforall Tbind Ty
+
+data Coercion
-- We distinguish primitive coercions because External Core treats
-- them specially, so we have to print them out with special syntax.
- | TransCoercion Ty Ty
- | SymCoercion Ty
- | UnsafeCoercion Ty Ty
- | InstCoercion Ty Ty
- | NthCoercion Int Ty
- | AxiomCoercion (Qual Tcon) Int [Ty]
- | LRCoercion LeftOrRight Ty
+ = ReflCoercion Role Ty
+ | SymCoercion Coercion
+ | TransCoercion Coercion Coercion
+ | TyConAppCoercion Role (Qual Tcon) [Coercion]
+ | AppCoercion Coercion Coercion
+ | ForAllCoercion Tbind Coercion
+ | CoVarCoercion Var
+ | UnivCoercion Role Ty Ty
+ | InstCoercion Coercion Ty
+ | NthCoercion Int Coercion
+ | AxiomCoercion (Qual Tcon) Int [Coercion]
+ | LRCoercion LeftOrRight Coercion
+ | SubCoercion Coercion
+
+data Role = Nominal | Representational | Phantom
data LeftOrRight = CLeft | CRight
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index e84dff900d..a0776af218 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -309,29 +309,29 @@ make_var_qid dflags force_unqual = make_qid dflags force_unqual True
make_con_qid :: DynFlags -> Name -> C.Qual C.Id
make_con_qid dflags = make_qid dflags False False
-make_co :: DynFlags -> Coercion -> C.Ty
-make_co dflags (Refl ty) = make_ty dflags ty
-make_co dflags (TyConAppCo tc cos) = make_conAppCo dflags (qtc dflags tc) cos
-make_co dflags (AppCo c1 c2) = C.Tapp (make_co dflags c1) (make_co dflags c2)
-make_co dflags (ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co dflags co)
-make_co _ (CoVarCo cv) = C.Tvar (make_var_id (coVarName cv))
+make_co :: DynFlags -> Coercion -> C.Coercion
+make_co dflags (Refl r ty) = C.ReflCoercion (make_role r) $ make_ty dflags ty
+make_co dflags (TyConAppCo r tc cos) = C.TyConAppCoercion (make_role r) (qtc dflags tc) (map (make_co dflags) cos)
+make_co dflags (AppCo c1 c2) = C.AppCoercion (make_co dflags c1) (make_co dflags c2)
+make_co dflags (ForAllCo tv co) = C.ForAllCoercion (make_tbind tv) (make_co dflags co)
+make_co _ (CoVarCo cv) = C.CoVarCoercion (make_var_id (coVarName cv))
make_co dflags (AxiomInstCo cc ind cos) = C.AxiomCoercion (qcc dflags cc) ind (map (make_co dflags) cos)
-make_co dflags (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty dflags t1) (make_ty dflags t2)
+make_co dflags (UnivCo r t1 t2) = C.UnivCoercion (make_role r) (make_ty dflags t1) (make_ty dflags t2)
make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co)
make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2)
make_co dflags (NthCo d co) = C.NthCoercion d (make_co dflags co)
make_co dflags (LRCo lr co) = C.LRCoercion (make_lr lr) (make_co dflags co)
make_co dflags (InstCo co ty) = C.InstCoercion (make_co dflags co) (make_ty dflags ty)
+make_co dflags (SubCo co) = C.SubCoercion (make_co dflags co)
make_lr :: LeftOrRight -> C.LeftOrRight
make_lr CLeft = C.CLeft
make_lr CRight = C.CRight
--- Used for both tycon app coercions and axiom instantiations.
-make_conAppCo :: DynFlags -> C.Qual C.Tcon -> [Coercion] -> C.Ty
-make_conAppCo dflags con cos =
- foldl C.Tapp (C.Tcon con)
- (map (make_co dflags) cos)
+make_role :: Role -> C.Role
+make_role Nominal = C.Nominal
+make_role Representational = C.Representational
+make_role Phantom = C.Phantom
-------
isALocal :: Name -> CoreM Bool
diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs
index 24ee560cb1..7fd3ac1d65 100644
--- a/compiler/coreSyn/PprExternalCore.lhs
+++ b/compiler/coreSyn/PprExternalCore.lhs
@@ -102,22 +102,6 @@ pbty t = paty t
pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2]
pty (Tforall tb t) = text "%forall" <+> pforall [tb] t
-pty (TransCoercion t1 t2) =
- sep [text "%trans", paty t1, paty t2]
-pty (SymCoercion t) =
- sep [text "%sym", paty t]
-pty (UnsafeCoercion t1 t2) =
- sep [text "%unsafe", paty t1, paty t2]
-pty (NthCoercion n t) =
- sep [text "%nth", int n, paty t]
-pty (LRCoercion CLeft t) =
- sep [text "%left", paty t]
-pty (LRCoercion CRight t) =
- sep [text "%right", paty t]
-pty (InstCoercion t1 t2) =
- sep [text "%inst", paty t1, paty t2]
-pty (AxiomCoercion tc i cos) =
- pqname tc <+> int i <+> sep (map paty cos)
pty ty@(Tapp {}) = pappty ty []
pty ty@(Tvar {}) = paty ty
pty ty@(Tcon {}) = paty ty
@@ -130,6 +114,48 @@ pforall :: [Tbind] -> Ty -> Doc
pforall tbs (Tforall tb t) = pforall (tbs ++ [tb]) t
pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t
+paco, pbco, pco :: Coercion -> Doc
+paco (ReflCoercion r ty) = char '<' <> pty ty <> text ">_" <> prole r
+paco (TyConAppCoercion r qtc []) = pqname qtc <> char '_' <> prole r
+paco (AxiomCoercion qtc i []) = pqname qtc <> char '[' <> int i <> char ']'
+paco (CoVarCoercion cv) = pname cv
+paco c = parens (pco c)
+
+pbco (TyConAppCoercion _ arr [co1, co2])
+ | arr == tcArrow
+ = parens (fsep [pbco co1, text "->", pco co2])
+pbco co = paco co
+
+pco c@(ReflCoercion {}) = paco c
+pco (SymCoercion co) = sep [text "%sub", paco co]
+pco (TransCoercion co1 co2) = sep [text "%trans", paco co1, paco co2]
+pco (TyConAppCoercion _ arr [co1, co2])
+ | arr == tcArrow = fsep [pbco co1, text "->", pco co2]
+pco (TyConAppCoercion r qtc cos) = parens (pqname qtc <+> sep (map paco cos)) <> char '_' <> prole r
+pco co@(AppCoercion {}) = pappco co []
+pco (ForAllCoercion tb co) = text "%forall" <+> pforallco [tb] co
+pco co@(CoVarCoercion {}) = paco co
+pco (UnivCoercion r ty1 ty2) = sep [text "%univ", prole r, paty ty1, paty ty2]
+pco (InstCoercion co ty) = sep [text "%inst", paco co, paty ty]
+pco (NthCoercion i co) = sep [text "%nth", int i, paco co]
+pco (AxiomCoercion qtc i cos) = pqname qtc <> char '[' <> int i <> char ']' <+> sep (map paco cos)
+pco (LRCoercion CLeft co) = sep [text "%left", paco co]
+pco (LRCoercion CRight co) = sep [text "%right", paco co]
+pco (SubCoercion co) = sep [text "%sub", paco co]
+
+pappco :: Coercion -> [Coercion ] -> Doc
+pappco (AppCoercion co1 co2) cos = pappco co1 (co2:cos)
+pappco co cos = sep (map paco (co:cos))
+
+pforallco :: [Tbind] -> Coercion -> Doc
+pforallco tbs (ForAllCoercion tb co) = pforallco (tbs ++ [tb]) co
+pforallco tbs co = hsep (map ptbind tbs) <+> char '.' <+> pco co
+
+prole :: Role -> Doc
+prole Nominal = char 'N'
+prole Representational = char 'R'
+prole Phantom = char 'P'
+
pvdefg :: Vdefg -> Doc
pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvdef vdefs))))
pvdefg (Nonrec vdef) = pvdef vdef
@@ -172,7 +198,7 @@ pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e)
pexp (Case e vb ty alts) = sep [text "%case" <+> paty ty <+> paexp e,
text "%of" <+> pvbind vb]
$$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))
-pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paty co
+pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paco co
pexp (Tick s e) = (text "%source" <+> pstring s) $$ pexp e
pexp (External n cc t) = (text "%external" <+> text cc <+> pstring n) $$ paty t
pexp (DynExternal cc t) = (text "%dynexternal" <+> text cc) $$ paty t
diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs
index c5cd9902bc..f8ad8da5f4 100644
--- a/compiler/coreSyn/TrieMap.lhs
+++ b/compiler/coreSyn/TrieMap.lhs
@@ -458,27 +458,28 @@ fdA k m = foldTM k (am_deflt m)
\begin{code}
data CoercionMap a
= EmptyKM
- | KM { km_refl :: TypeMap a
- , km_tc_app :: NameEnv (ListMap CoercionMap a)
+ | KM { km_refl :: RoleMap (TypeMap a)
+ , km_tc_app :: RoleMap (NameEnv (ListMap CoercionMap a))
, km_app :: CoercionMap (CoercionMap a)
, km_forall :: CoercionMap (TypeMap a)
, km_var :: VarMap a
, km_axiom :: NameEnv (IntMap.IntMap (ListMap CoercionMap a))
- , km_unsafe :: TypeMap (TypeMap a)
+ , km_univ :: RoleMap (TypeMap (TypeMap a))
, km_sym :: CoercionMap a
, km_trans :: CoercionMap (CoercionMap a)
, km_nth :: IntMap.IntMap (CoercionMap a)
, km_left :: CoercionMap a
, km_right :: CoercionMap a
- , km_inst :: CoercionMap (TypeMap a) }
+ , km_inst :: CoercionMap (TypeMap a)
+ , km_sub :: CoercionMap a }
wrapEmptyKM :: CoercionMap a
-wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyNameEnv
+wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyTM
, km_app = emptyTM, km_forall = emptyTM
, km_var = emptyTM, km_axiom = emptyNameEnv
- , km_unsafe = emptyTM, km_sym = emptyTM, km_trans = emptyTM
+ , km_univ = emptyTM, km_sym = emptyTM, km_trans = emptyTM
, km_nth = emptyTM, km_left = emptyTM, km_right = emptyTM
- , km_inst = emptyTM }
+ , km_inst = emptyTM, km_sub = emptyTM }
instance TrieMap CoercionMap where
type Key CoercionMap = Coercion
@@ -493,34 +494,35 @@ mapC _ EmptyKM = EmptyKM
mapC f (KM { km_refl = krefl, km_tc_app = ktc
, km_app = kapp, km_forall = kforall
, km_var = kvar, km_axiom = kax
- , km_unsafe = kunsafe, km_sym = ksym, km_trans = ktrans
+ , km_univ = kuniv , km_sym = ksym, km_trans = ktrans
, km_nth = knth, km_left = kml, km_right = kmr
- , km_inst = kinst })
- = KM { km_refl = mapTM f krefl
- , km_tc_app = mapNameEnv (mapTM f) ktc
+ , km_inst = kinst, km_sub = ksub })
+ = KM { km_refl = mapTM (mapTM f) krefl
+ , km_tc_app = mapTM (mapNameEnv (mapTM f)) ktc
, km_app = mapTM (mapTM f) kapp
, km_forall = mapTM (mapTM f) kforall
, km_var = mapTM f kvar
, km_axiom = mapNameEnv (IntMap.map (mapTM f)) kax
- , km_unsafe = mapTM (mapTM f) kunsafe
+ , km_univ = mapTM (mapTM (mapTM f)) kuniv
, km_sym = mapTM f ksym
, km_trans = mapTM (mapTM f) ktrans
, km_nth = IntMap.map (mapTM f) knth
, km_left = mapTM f kml
, km_right = mapTM f kmr
- , km_inst = mapTM (mapTM f) kinst }
+ , km_inst = mapTM (mapTM f) kinst
+ , km_sub = mapTM f ksub }
lkC :: CmEnv -> Coercion -> CoercionMap a -> Maybe a
lkC env co m
| EmptyKM <- m = Nothing
| otherwise = go co m
where
- go (Refl ty) = km_refl >.> lkT env ty
- go (TyConAppCo tc cs) = km_tc_app >.> lkNamed tc >=> lkList (lkC env) cs
+ go (Refl r ty) = km_refl >.> lookupTM r >=> lkT env ty
+ go (TyConAppCo r tc cs) = km_tc_app >.> lookupTM r >=> lkNamed tc >=> lkList (lkC env) cs
go (AxiomInstCo ax ind cs) = km_axiom >.> lkNamed ax >=> lookupTM ind >=> lkList (lkC env) cs
go (AppCo c1 c2) = km_app >.> lkC env c1 >=> lkC env c2
go (TransCo c1 c2) = km_trans >.> lkC env c1 >=> lkC env c2
- go (UnsafeCo t1 t2) = km_unsafe >.> lkT env t1 >=> lkT env t2
+ go (UnivCo r t1 t2) = km_univ >.> lookupTM r >=> lkT env t1 >=> lkT env t2
go (InstCo c t) = km_inst >.> lkC env c >=> lkT env t
go (ForAllCo v c) = km_forall >.> lkC (extendCME env v) c >=> lkBndr env v
go (CoVarCo v) = km_var >.> lkVar env v
@@ -528,15 +530,16 @@ lkC env co m
go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c
go (LRCo CLeft c) = km_left >.> lkC env c
go (LRCo CRight c) = km_right >.> lkC env c
+ go (SubCo c) = km_sub >.> lkC env c
xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a
xtC env co f EmptyKM = xtC env co f wrapEmptyKM
-xtC env (Refl ty) f m = m { km_refl = km_refl m |> xtT env ty f }
-xtC env (TyConAppCo tc cs) f m = m { km_tc_app = km_tc_app m |> xtNamed tc |>> xtList (xtC env) cs f }
+xtC env (Refl r ty) f m = m { km_refl = km_refl m |> xtR r |>> xtT env ty f }
+xtC env (TyConAppCo r tc cs) f m = m { km_tc_app = km_tc_app m |> xtR r |>> xtNamed tc |>> xtList (xtC env) cs f }
xtC env (AxiomInstCo ax ind cs) f m = m { km_axiom = km_axiom m |> xtNamed ax |>> xtInt ind |>> xtList (xtC env) cs f }
xtC env (AppCo c1 c2) f m = m { km_app = km_app m |> xtC env c1 |>> xtC env c2 f }
xtC env (TransCo c1 c2) f m = m { km_trans = km_trans m |> xtC env c1 |>> xtC env c2 f }
-xtC env (UnsafeCo t1 t2) f m = m { km_unsafe = km_unsafe m |> xtT env t1 |>> xtT env t2 f }
+xtC env (UnivCo r t1 t2) f m = m { km_univ = km_univ m |> xtR r |>> xtT env t1 |>> xtT env t2 f }
xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f }
xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c
|>> xtBndr env v f }
@@ -544,23 +547,56 @@ xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f
xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f }
xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f }
xtC env (LRCo CLeft c) f m = m { km_left = km_left m |> xtC env c f }
-xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f }
+xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f }
+xtC env (SubCo c) f m = m { km_sub = km_sub m |> xtC env c f }
fdC :: (a -> b -> b) -> CoercionMap a -> b -> b
fdC _ EmptyKM = \z -> z
-fdC k m = foldTM k (km_refl m)
- . foldTM (foldTM k) (km_tc_app m)
+fdC k m = foldTM (foldTM k) (km_refl m)
+ . foldTM (foldTM (foldTM k)) (km_tc_app m)
. foldTM (foldTM k) (km_app m)
. foldTM (foldTM k) (km_forall m)
. foldTM k (km_var m)
. foldTM (foldTM (foldTM k)) (km_axiom m)
- . foldTM (foldTM k) (km_unsafe m)
+ . foldTM (foldTM (foldTM k)) (km_univ m)
. foldTM k (km_sym m)
. foldTM (foldTM k) (km_trans m)
. foldTM (foldTM k) (km_nth m)
. foldTM k (km_left m)
. foldTM k (km_right m)
. foldTM (foldTM k) (km_inst m)
+ . foldTM k (km_sub m)
+
+\end{code}
+
+\begin{code}
+
+newtype RoleMap a = RM { unRM :: (IntMap.IntMap a) }
+
+instance TrieMap RoleMap where
+ type Key RoleMap = Role
+ emptyTM = RM emptyTM
+ lookupTM = lkR
+ alterTM = xtR
+ foldTM = fdR
+ mapTM = mapR
+
+lkR :: Role -> RoleMap a -> Maybe a
+lkR Nominal = lookupTM 1 . unRM
+lkR Representational = lookupTM 2 . unRM
+lkR Phantom = lookupTM 3 . unRM
+
+xtR :: Role -> XT a -> RoleMap a -> RoleMap a
+xtR Nominal f = RM . alterTM 1 f . unRM
+xtR Representational f = RM . alterTM 2 f . unRM
+xtR Phantom f = RM . alterTM 3 f . unRM
+
+fdR :: (a -> b -> b) -> RoleMap a -> b -> b
+fdR f (RM m) = foldTM f m
+
+mapR :: (a -> b) -> RoleMap a -> RoleMap b
+mapR f = RM . mapTM f . unRM
+
\end{code}
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 66022f970e..617516bd97 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -65,6 +65,7 @@ import Maybes
import OrdList
import Bag
import BasicTypes hiding ( TopLevel )
+import Pair
import DynFlags
import FastString
import ErrUtils( MsgDoc )
@@ -705,7 +706,7 @@ dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty)
dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds
return (mkCoreLets bs e)
dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e
-dsHsWrapper (WpCast co) e = dsTcCoercion co (mkCast e)
+dsHsWrapper (WpCast co) e = dsTcCoercion Representational co (mkCast e)
dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
dsHsWrapper (WpEvApp evtrm) e = liftM (App e) (dsEvTerm evtrm)
@@ -739,7 +740,7 @@ dsEvTerm (EvId v) = return (Var v)
dsEvTerm (EvCast tm co)
= do { tm' <- dsEvTerm tm
- ; dsTcCoercion co $ mkCast tm' }
+ ; dsTcCoercion Representational co $ mkCast tm' }
-- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
@@ -747,7 +748,7 @@ dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms
; return (Var df `mkTyApps` tys `mkApps` tms') }
dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions]
-dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
+dsEvTerm (EvCoercion co) = dsTcCoercion Nominal co mkEqBox
dsEvTerm (EvTupleSel v n)
= do { tm' <- dsEvTerm v
@@ -785,21 +786,22 @@ dsEvTerm (EvLit l) =
EvStr s -> mkStringExprFS s
---------------------------------------
-dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
+dsTcCoercion :: Role -> TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
-- This is the crucial function that moves
-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
-- e.g. dsTcCoercion (trans g1 g2) k
-- = case g1 of EqBox g1# ->
-- case g2 of EqBox g2# ->
-- k (trans g1# g2#)
-dsTcCoercion co thing_inside
+-- thing_inside will get a coercion at the role requested
+dsTcCoercion role co thing_inside
= do { us <- newUniqueSupply
; let eqvs_covs :: [(EqVar,CoVar)]
eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))
(uniqsFromSupply us)
subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
- result_expr = thing_inside (ds_tc_coercion subst co)
+ result_expr = thing_inside (ds_tc_coercion subst role co)
result_ty = exprType result_expr
; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }
@@ -810,36 +812,41 @@ dsTcCoercion co thing_inside
eq_nm = idName eqv
occ = nameOccName eq_nm
loc = nameSrcSpan eq_nm
- ty = mkCoercionType ty1 ty2
+ ty = mkCoercionType Nominal ty1 ty2
(ty1, ty2) = getEqPredTys (evVarPred eqv)
wrap_in_case result_ty (eqv, cov) body
= Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
-ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
+ds_tc_coercion :: CvSubst -> Role -> TcCoercion -> Coercion
-- If the incoming TcCoercion if of type (a ~ b),
-- the result is of type (a ~# b)
-- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b)
-- No need for InScope set etc because the
-ds_tc_coercion subst tc_co
- = go tc_co
+ds_tc_coercion subst role tc_co
+ = go role tc_co
where
- go (TcRefl ty) = Refl (Coercion.substTy subst ty)
- go (TcTyConAppCo tc cos) = mkTyConAppCo tc (map go cos)
- go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2)
- go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co)
+ go Phantom co
+ = mkUnivCo Phantom ty1 ty2
+ where Pair ty1 ty2 = tcCoercionKind co
+
+ go r (TcRefl ty) = Refl r (Coercion.substTy subst ty)
+ go r (TcTyConAppCo tc cos) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) cos)
+ go r (TcAppCo co1 co2) = mkAppCo (go r co1) (go Nominal co2)
+ go r (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' r co)
where
(subst', tv') = Coercion.substTyVarBndr subst tv
- go (TcAxiomInstCo ax ind tys)
- = mkAxInstCo ax ind (map (Coercion.substTy subst) tys)
- go (TcSymCo co) = mkSymCo (go co)
- go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2)
- go (TcNthCo n co) = mkNthCo n (go co)
- go (TcLRCo lr co) = mkLRCo lr (go co)
- go (TcInstCo co ty) = mkInstCo (go co) ty
- go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co
- go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2)
- go (TcCoVarCo v) = ds_ev_id subst v
+ go r (TcAxiomInstCo ax ind tys)
+ = mkAxInstCo r ax ind (map (Coercion.substTy subst) tys)
+ go r (TcSymCo co) = mkSymCo (go r co)
+ go r (TcTransCo co1 co2) = mkTransCo (go r co1) (go r co2)
+ go r (TcNthCo n co) = mkNthCoRole r n (go r co) -- the 2nd r is a harmless lie
+ go r (TcLRCo lr co) = maybeSubCo r $ mkLRCo lr (go Nominal co)
+ go r (TcInstCo co ty) = mkInstCo (go r co) ty
+ go r (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) r co
+ go r (TcCastCo co1 co2) = maybeSubCo r $ mkCoCast (go Nominal co1)
+ (go Nominal co2)
+ go r (TcCoVarCo v) = maybeSubCo r $ ds_ev_id subst v
ds_co_binds :: TcEvBinds -> CvSubst
ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs)
@@ -851,9 +858,9 @@ ds_tc_coercion subst tc_co
ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
ds_co_term :: CvSubst -> EvTerm -> Coercion
- ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
+ ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst Nominal tc_co
ds_co_term subst (EvId v) = ds_ev_id subst v
- ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co)
+ ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst Nominal co)
ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co)
ds_ev_id :: CvSubst -> EqVar -> Coercion
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 9be8e96615..1053b91aaa 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -418,7 +418,7 @@ dsFExportDynamic id co0 cconv = do
export_ty = mkFunTy stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName
stbl_value <- newSysLocalDs stable_ptr_ty
- (h_code, c_code, typestring, args_size) <- dsFExport id (Refl export_ty) fe_nm cconv True
+ (h_code, c_code, typestring, args_size) <- dsFExport id (mkReflCo Representational export_ty) fe_nm cconv True
let
{-
The arguments to the external function which will
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index a60f18ded5..f92f6212a0 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -305,7 +305,7 @@ mk_extra_tvs tc tvs defn
= do { uniq <- newUnique
; let { occ = mkTyVarOccFS (fsLit "t")
; nm = mkInternalName uniq occ loc
- ; hs_tv = L loc (KindedTyVar nm kind) }
+ ; hs_tv = L loc (HsTyVarBndr nm (Just kind) Nothing) }
; hs_tvs <- go rest
; return (hs_tv : hs_tvs) }
@@ -731,10 +731,16 @@ addTyClTyVarBinds tvs m
--
repTyVarBndrWithKind :: LHsTyVarBndr Name
-> Core TH.Name -> DsM (Core TH.TyVarBndr)
-repTyVarBndrWithKind (L _ (UserTyVar {})) nm
+repTyVarBndrWithKind (L _ (HsTyVarBndr _ Nothing Nothing)) nm
= repPlainTV nm
-repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
+repTyVarBndrWithKind (L _ (HsTyVarBndr _ (Just ki) Nothing)) nm
= repLKind ki >>= repKindedTV nm
+repTyVarBndrWithKind (L _ (HsTyVarBndr _ Nothing (Just r))) nm
+ = repRole r >>= repRoledTV nm
+repTyVarBndrWithKind (L _ (HsTyVarBndr _ (Just ki) (Just r))) nm
+ = do { ki' <- repLKind ki
+ ; r' <- repRole r
+ ; repKindedRoledTV nm ki' r' }
-- represent a type context
--
@@ -878,6 +884,11 @@ repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks
}
repNonArrowKind k = notHandled "Exotic form of kind" (ppr k)
+repRole :: Role -> DsM (Core TH.Role)
+repRole Nominal = rep2 nominalName []
+repRole Representational = rep2 representationalName []
+repRole Phantom = rep2 phantomName []
+
-----------------------------------------------------------------------------
-- Splices
-----------------------------------------------------------------------------
@@ -1828,6 +1839,13 @@ repPlainTV (MkC nm) = rep2 plainTVName [nm]
repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
+repRoledTV :: Core TH.Name -> Core TH.Role -> DsM (Core TH.TyVarBndr)
+repRoledTV (MkC nm) (MkC r) = rep2 roledTVName [nm, r]
+
+repKindedRoledTV :: Core TH.Name -> Core TH.Kind -> Core TH.Role
+ -> DsM (Core TH.TyVarBndr)
+repKindedRoledTV (MkC nm) (MkC k) (MkC r) = rep2 kindedRoledTVName [nm, k, r]
+
repKVar :: Core TH.Name -> DsM (Core TH.Kind)
repKVar (MkC s) = rep2 varKName [s]
@@ -2041,7 +2059,9 @@ templateHaskellNames = [
-- TyLit
numTyLitName, strTyLitName,
-- TyVarBndr
- plainTVName, kindedTVName,
+ plainTVName, kindedTVName, roledTVName, kindedRoledTVName,
+ -- Role
+ nominalName, representationalName, phantomName,
-- Kind
varKName, conKName, tupleKName, arrowKName, listKName, appKName,
starKName, constraintKName,
@@ -2319,9 +2339,17 @@ numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey
strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey
-- data TyVarBndr = ...
-plainTVName, kindedTVName :: Name
-plainTVName = libFun (fsLit "plainTV") plainTVIdKey
-kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
+plainTVName, kindedTVName, roledTVName, kindedRoledTVName :: Name
+plainTVName = libFun (fsLit "plainTV") plainTVIdKey
+kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
+roledTVName = libFun (fsLit "roledTV") roledTVIdKey
+kindedRoledTVName = libFun (fsLit "kindedRoledTV") kindedRoledTVIdKey
+
+-- data Role = ...
+nominalName, representationalName, phantomName :: Name
+nominalName = libFun (fsLit "nominal") nominalIdKey
+representationalName = libFun (fsLit "representational") representationalIdKey
+phantomName = libFun (fsLit "phantom") phantomIdKey
-- data Kind = ...
varKName, conKName, tupleKName, arrowKName, listKName, appKName,
@@ -2589,8 +2617,8 @@ forImpDIdKey = mkPreludeMiscIdUnique 338
pragInlDIdKey = mkPreludeMiscIdUnique 339
pragSpecDIdKey = mkPreludeMiscIdUnique 340
pragSpecInlDIdKey = mkPreludeMiscIdUnique 341
-pragSpecInstDIdKey = mkPreludeMiscIdUnique 412
-pragRuleDIdKey = mkPreludeMiscIdUnique 413
+pragSpecInstDIdKey = mkPreludeMiscIdUnique 416
+pragRuleDIdKey = mkPreludeMiscIdUnique 417
familyNoKindDIdKey = mkPreludeMiscIdUnique 342
familyKindDIdKey = mkPreludeMiscIdUnique 343
dataInstDIdKey = mkPreludeMiscIdUnique 344
@@ -2658,32 +2686,40 @@ numTyLitIdKey = mkPreludeMiscIdUnique 394
strTyLitIdKey = mkPreludeMiscIdUnique 395
-- data TyVarBndr = ...
-plainTVIdKey, kindedTVIdKey :: Unique
-plainTVIdKey = mkPreludeMiscIdUnique 396
-kindedTVIdKey = mkPreludeMiscIdUnique 397
+plainTVIdKey, kindedTVIdKey, roledTVIdKey, kindedRoledTVIdKey :: Unique
+plainTVIdKey = mkPreludeMiscIdUnique 396
+kindedTVIdKey = mkPreludeMiscIdUnique 397
+roledTVIdKey = mkPreludeMiscIdUnique 398
+kindedRoledTVIdKey = mkPreludeMiscIdUnique 399
+
+-- data Role = ...
+nominalIdKey, representationalIdKey, phantomIdKey :: Unique
+nominalIdKey = mkPreludeMiscIdUnique 400
+representationalIdKey = mkPreludeMiscIdUnique 401
+phantomIdKey = mkPreludeMiscIdUnique 402
-- data Kind = ...
varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,
starKIdKey, constraintKIdKey :: Unique
-varKIdKey = mkPreludeMiscIdUnique 398
-conKIdKey = mkPreludeMiscIdUnique 399
-tupleKIdKey = mkPreludeMiscIdUnique 400
-arrowKIdKey = mkPreludeMiscIdUnique 401
-listKIdKey = mkPreludeMiscIdUnique 402
-appKIdKey = mkPreludeMiscIdUnique 403
-starKIdKey = mkPreludeMiscIdUnique 404
-constraintKIdKey = mkPreludeMiscIdUnique 405
+varKIdKey = mkPreludeMiscIdUnique 403
+conKIdKey = mkPreludeMiscIdUnique 404
+tupleKIdKey = mkPreludeMiscIdUnique 405
+arrowKIdKey = mkPreludeMiscIdUnique 406
+listKIdKey = mkPreludeMiscIdUnique 407
+appKIdKey = mkPreludeMiscIdUnique 408
+starKIdKey = mkPreludeMiscIdUnique 409
+constraintKIdKey = mkPreludeMiscIdUnique 410
-- data Callconv = ...
cCallIdKey, stdCallIdKey :: Unique
-cCallIdKey = mkPreludeMiscIdUnique 406
-stdCallIdKey = mkPreludeMiscIdUnique 407
+cCallIdKey = mkPreludeMiscIdUnique 411
+stdCallIdKey = mkPreludeMiscIdUnique 412
-- data Safety = ...
unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
-unsafeIdKey = mkPreludeMiscIdUnique 408
-safeIdKey = mkPreludeMiscIdUnique 409
-interruptibleIdKey = mkPreludeMiscIdUnique 411
+unsafeIdKey = mkPreludeMiscIdUnique 413
+safeIdKey = mkPreludeMiscIdUnique 414
+interruptibleIdKey = mkPreludeMiscIdUnique 415
-- data Inline = ...
noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
@@ -2704,25 +2740,25 @@ beforePhaseDataConKey = mkPreludeDataConUnique 47
-- data FunDep = ...
funDepIdKey :: Unique
-funDepIdKey = mkPreludeMiscIdUnique 414
+funDepIdKey = mkPreludeMiscIdUnique 418
-- data FamFlavour = ...
typeFamIdKey, dataFamIdKey :: Unique
-typeFamIdKey = mkPreludeMiscIdUnique 415
-dataFamIdKey = mkPreludeMiscIdUnique 416
+typeFamIdKey = mkPreludeMiscIdUnique 419
+dataFamIdKey = mkPreludeMiscIdUnique 420
-- data TySynEqn = ...
tySynEqnIdKey :: Unique
-tySynEqnIdKey = mkPreludeMiscIdUnique 417
+tySynEqnIdKey = mkPreludeMiscIdUnique 421
-- quasiquoting
quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
-quoteExpKey = mkPreludeMiscIdUnique 418
-quotePatKey = mkPreludeMiscIdUnique 419
-quoteDecKey = mkPreludeMiscIdUnique 420
-quoteTypeKey = mkPreludeMiscIdUnique 421
+quoteExpKey = mkPreludeMiscIdUnique 422
+quotePatKey = mkPreludeMiscIdUnique 423
+quoteDecKey = mkPreludeMiscIdUnique 424
+quoteTypeKey = mkPreludeMiscIdUnique 425
-- data RuleBndr = ...
ruleVarIdKey, typedRuleVarIdKey :: Unique
-ruleVarIdKey = mkPreludeMiscIdUnique 422
-typedRuleVarIdKey = mkPreludeMiscIdUnique 423
+ruleVarIdKey = mkPreludeMiscIdUnique 426
+typedRuleVarIdKey = mkPreludeMiscIdUnique 427
diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index 9906467186..e3119a7842 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -41,8 +41,10 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Data.Array.MArray
-import Data.Array.Unboxed ( listArray )
+
+import qualified Data.Array.Unboxed as Array
import Data.Array.Base ( UArray(..) )
+
import Data.Array.Unsafe( castSTUArray )
import Foreign
@@ -161,11 +163,11 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d
let asm_insns = ssElts final_insns
barr a = case a of UArray _lo _hi _n b -> b
- insns_arr = listArray (0, n_insns - 1) asm_insns
+ insns_arr = Array.listArray (0, n_insns - 1) asm_insns
!insns_barr = barr insns_arr
bitmap_arr = mkBitmapArray dflags bsize bitmap
- !bitmap_barr = barr bitmap_arr
+ !bitmap_barr = toByteArray bitmap_arr
ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs
@@ -176,9 +178,15 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d
return ul_bco
+#if __GLASGOW_HASKELL__ > 706
+mkBitmapArray :: DynFlags -> Word16 -> [StgWord] -> UArrayStgWord Int
+mkBitmapArray dflags bsize bitmap
+ = SMRep.listArray (0, length bitmap) (toStgWord dflags (toInteger bsize) : bitmap)
+#else
mkBitmapArray :: DynFlags -> Word16 -> [StgWord] -> UArray Int StgWord
mkBitmapArray dflags bsize bitmap
- = listArray (0, length bitmap) (toStgWord dflags (toInteger bsize) : bitmap)
+ = Array.listArray (0, length bitmap) (toStgWord dflags (toInteger bsize) : bitmap)
+#endif
-- instrs nonptrs ptrs
type AsmState = (SizedSeq Word16,
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index f7d5bdb084..383b641262 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -20,6 +20,7 @@ import qualified OccName
import OccName
import SrcLoc
import Type
+import qualified Coercion ( Role(..) )
import TysWiredIn
import BasicTypes as Hs
import ForeignCall
@@ -847,11 +848,25 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
cvt_tv (TH.PlainTV nm)
= do { nm' <- tName nm
- ; returnL $ UserTyVar nm' }
+ ; returnL $ HsTyVarBndr nm' Nothing Nothing }
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tName nm
; ki' <- cvtKind ki
- ; returnL $ KindedTyVar nm' ki' }
+ ; returnL $ HsTyVarBndr nm' (Just ki') Nothing }
+cvt_tv (TH.RoledTV nm r)
+ = do { nm' <- tName nm
+ ; r' <- cvtRole r
+ ; returnL $ HsTyVarBndr nm' Nothing (Just r') }
+cvt_tv (TH.KindedRoledTV nm k r)
+ = do { nm' <- tName nm
+ ; k' <- cvtKind k
+ ; r' <- cvtRole r
+ ; returnL $ HsTyVarBndr nm' (Just k') (Just r') }
+
+cvtRole :: TH.Role -> CvtM Coercion.Role
+cvtRole TH.Nominal = return Coercion.Nominal
+cvtRole TH.Representational = return Coercion.Representational
+cvtRole TH.Phantom = return Coercion.Phantom
cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index eeed5cdbfb..82b0cf244b 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -47,6 +47,7 @@ import Name( Name )
import RdrName( RdrName )
import DataCon( HsBang(..) )
import Type
+import TyCon ( Role(..) )
import HsDoc
import BasicTypes
import SrcLoc
@@ -179,20 +180,15 @@ instance OutputableBndr HsIPName where
pprInfixOcc n = ppr n
pprPrefixOcc n = ppr n
-
data HsTyVarBndr name
- = UserTyVar -- No explicit kinding
- name -- See Note [Printing KindedTyVars]
-
- | KindedTyVar
- name
- (LHsKind name) -- The user-supplied kind signature
+ = HsTyVarBndr name
+ (Maybe (LHsKind name)) -- See Note [Printing KindedTyVars]
+ (Maybe Role)
-- *** NOTA BENE *** A "monotype" in a pragma can have
-- for-alls in it, (mostly to do with dictionaries). These
-- must be explicitly Kinded.
deriving (Data, Typeable)
-
data HsType name
= HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way
-- the user wrote it originally, so that the printer can
@@ -232,6 +228,9 @@ data HsType name
| HsKindSig (LHsType name) -- (ty :: kind)
(LHsKind name) -- A type with a kind signature
+ | HsRoleAnnot (LHsType name) -- ty@role, seen only right after parsing
+ Role
+
| HsQuasiQuoteTy (HsQuasiQuote name)
| HsSpliceTy (HsSplice name)
@@ -421,8 +420,7 @@ hsExplicitTvs _ = []
---------------------
hsTyVarName :: HsTyVarBndr name -> name
-hsTyVarName (UserTyVar n) = n
-hsTyVarName (KindedTyVar n _) = n
+hsTyVarName (HsTyVarBndr n _ _) = n
hsLTyVarName :: LHsTyVarBndr name -> name
hsLTyVarName = hsTyVarName . unLoc
@@ -529,8 +527,10 @@ instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where
= sep [ ifPprDebug $ braces (interppSP kvs), interppSP tvs ]
instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
- ppr (UserTyVar name) = ppr name
- ppr (KindedTyVar name kind) = parens $ hsep [ppr name, dcolon, ppr kind]
+ ppr (HsTyVarBndr n Nothing Nothing) = ppr n
+ ppr (HsTyVarBndr n (Just k) Nothing) = parens $ hsep [ppr n, dcolon, ppr k]
+ ppr (HsTyVarBndr n Nothing (Just r)) = ppr n <> char '@' <> ppr r
+ ppr (HsTyVarBndr n (Just k) (Just r)) = parens $ hsep [ppr n, dcolon, ppr k] <> char '@' <> ppr r
instance (Outputable thing) => Outputable (HsWithBndrs thing) where
ppr (HsWB { hswb_cts = ty }) = ppr ty
@@ -622,6 +622,7 @@ ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
HsUnboxedTuple -> UnboxedTuple
_ -> BoxedTuple
ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind)
+ppr_mono_ty _ (HsRoleAnnot ty r) = ppr ty <> char '@' <> ppr r
ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty)
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 1fa949653e..267b2cac0e 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -271,7 +271,7 @@ mkHsString s = HsString (mkFastString s)
-------------
userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
-- Caller sets location
-userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
+userHsTyVarBndrs loc bndrs = [ L loc (HsTyVarBndr v Nothing Nothing) | v <- bndrs ]
\end{code}
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 0876d906ab..b0bb88789d 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -415,3 +415,4 @@ getWayDescr dflags
-- if this is an unregisterised build, make sure our interfaces
-- can't be used by a registerised build.
+
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index a541e32b7b..20aea22e47 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -46,13 +46,13 @@ import Outputable
\begin{code}
------------------------------------------------------
-buildSynTyCon :: Name -> [TyVar]
+buildSynTyCon :: Name -> [TyVar] -> [Role]
-> SynTyConRhs
-> Kind -- ^ Kind of the RHS
-> TyConParent
-> TcRnIf m n TyCon
-buildSynTyCon tc_name tvs rhs rhs_kind parent
- = return (mkSynTyCon tc_name kind tvs rhs parent)
+buildSynTyCon tc_name tvs roles rhs rhs_kind parent
+ = return (mkSynTyCon tc_name kind tvs roles rhs parent)
where kind = mkPiKinds tvs rhs_kind
@@ -80,7 +80,7 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
-- because the latter is part of a knot, whereas the former is not.
mkNewTyConRhs tycon_name tycon con
= do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
- ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_rhs
+ ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_roles etad_rhs
; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon)
; return (NewTyCon { data_con = con,
nt_rhs = rhs_ty,
@@ -90,6 +90,7 @@ mkNewTyConRhs tycon_name tycon con
-- for nt_co, or uses explicit coercions otherwise
where
tvs = tyConTyVars tycon
+ roles = tyConRoles tycon
inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
-- Instantiate the data con with the
@@ -101,20 +102,22 @@ mkNewTyConRhs tycon_name tycon con
-- has a single argument (Foo a) that is a *type class*, so
-- dataConInstOrigArgTys returns [].
- etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can
- etad_rhs :: Type -- return a TyCon without pulling on rhs_ty
- -- See Note [Tricky iface loop] in LoadIface
- (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty
+ etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can
+ etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty
+ etad_rhs :: Type -- See Note [Tricky iface loop] in LoadIface
+ (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty
- eta_reduce :: [TyVar] -- Reversed
- -> Type -- Rhs type
- -> ([TyVar], Type) -- Eta-reduced version (tyvars in normal order)
- eta_reduce (a:as) ty | Just (fun, arg) <- splitAppTy_maybe ty,
- Just tv <- getTyVar_maybe arg,
- tv == a,
- not (a `elemVarSet` tyVarsOfType fun)
- = eta_reduce as fun
- eta_reduce tvs ty = (reverse tvs, ty)
+ eta_reduce :: [TyVar] -- Reversed
+ -> [Role] -- also reversed
+ -> Type -- Rhs type
+ -> ([TyVar], [Role], Type) -- Eta-reduced version
+ -- (tyvars in normal order)
+ eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
+ Just tv <- getTyVar_maybe arg,
+ tv == a,
+ not (a `elemVarSet` tyVarsOfType fun)
+ = eta_reduce as rs fun
+ eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
------------------------------------------------------
@@ -185,14 +188,14 @@ type TcMethInfo = (Name, DefMethSpec, Type)
buildClass :: Bool -- True <=> do not include unfoldings
-- on dict selectors
-- Used when importing a class without -O
- -> Name -> [TyVar] -> ThetaType
+ -> Name -> [TyVar] -> [Role] -> ThetaType
-> [FunDep TyVar] -- Functional dependencies
-> [ClassATItem] -- Associated types
-> [TcMethInfo] -- Method info
-> RecFlag -- Info for type constructor
-> TcRnIf m n Class
-buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec
+buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff tc_isrec
= fixM $ \ rec_clas -> -- Only name generation inside loop
do { traceIf (text "buildClass")
; dflags <- getDynFlags
@@ -255,7 +258,7 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec
; let { clas_kind = mkPiKinds tvs constraintKind
- ; tycon = mkClassTyCon tycon_name clas_kind tvs
+ ; tycon = mkClassTyCon tycon_name clas_kind tvs roles
rhs rec_clas tc_isrec
-- A class can be recursive, and in the case of newtypes
-- this matters. For example
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 7eb3d3a119..3bbcdd395e 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -42,7 +42,7 @@ import Demand
import Annotations
import Class
import NameSet
-import CoAxiom ( BranchIndex )
+import CoAxiom ( BranchIndex, Role )
import Name
import CostCentre
import Literal
@@ -79,6 +79,7 @@ data IfaceDecl
| IfaceData { ifName :: OccName, -- 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
ifRec :: RecFlag, -- Recursive or not?
@@ -91,12 +92,14 @@ data IfaceDecl
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifRoles :: [Role], -- Roles
ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon)
ifSynRhs :: IfaceSynTyConRhs }
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
ifName :: OccName, -- Name of the class TyCon
ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifRoles :: [Role], -- Roles
ifFDs :: [FunDep FastString], -- Functional dependencies
ifATs :: [IfaceAT], -- Associated type families
ifSigs :: [IfaceClassOp], -- Method signatures
@@ -106,6 +109,7 @@ data IfaceDecl
| IfaceAxiom { ifName :: OccName, -- Axiom name
ifTyCon :: IfaceTyCon, -- LHS TyCon
+ ifRole :: Role, -- Role of axiom
ifAxBranches :: [IfaceAxBranch] -- Branches
}
@@ -130,7 +134,7 @@ instance Binary IfaceDecl where
put_ _ (IfaceForeign _ _) =
error "Binary.put_(IfaceDecl): IfaceForeign"
- put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
+ put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
putByte bh 2
put_ bh (occNameFS a1)
put_ bh a2
@@ -141,15 +145,17 @@ instance Binary IfaceDecl where
put_ bh a7
put_ bh a8
put_ bh a9
+ put_ bh a10
- put_ bh (IfaceSyn a1 a2 a3 a4) = do
+ put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
putByte bh 3
put_ bh (occNameFS a1)
put_ bh a2
put_ bh a3
put_ bh a4
+ put_ bh a5
- put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
+ put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8) = do
putByte bh 4
put_ bh a1
put_ bh (occNameFS a2)
@@ -158,12 +164,14 @@ instance Binary IfaceDecl where
put_ bh a5
put_ bh a6
put_ bh a7
+ put_ bh a8
- put_ bh (IfaceAxiom a1 a2 a3) = do
+ put_ bh (IfaceAxiom a1 a2 a3 a4) = do
putByte bh 5
put_ bh (occNameFS a1)
put_ bh a2
put_ bh a3
+ put_ bh a4
get bh = do
h <- getByte bh
@@ -175,23 +183,25 @@ instance Binary IfaceDecl where
occ <- return $! mkOccNameFS varName name
return (IfaceId occ ty details idinfo)
1 -> error "Binary.get(TyClDecl): ForeignType"
- 2 -> do a1 <- get bh
- a2 <- get bh
- a3 <- get bh
- a4 <- get bh
- a5 <- get bh
- a6 <- get bh
- a7 <- get bh
- a8 <- get bh
- a9 <- get bh
+ 2 -> do a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ a7 <- get bh
+ a8 <- get bh
+ a9 <- get bh
+ a10 <- get bh
occ <- return $! mkOccNameFS tcName a1
- return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9)
+ return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9 a10)
3 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
a4 <- get bh
+ a5 <- get bh
occ <- return $! mkOccNameFS tcName a1
- return (IfaceSyn occ a2 a3 a4)
+ return (IfaceSyn occ a2 a3 a4 a5)
4 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
@@ -199,13 +209,15 @@ instance Binary IfaceDecl where
a5 <- get bh
a6 <- get bh
a7 <- get bh
+ a8 <- get bh
occ <- return $! mkOccNameFS clsName a2
- return (IfaceClass a1 occ a3 a4 a5 a6 a7)
+ return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8)
_ -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
+ a4 <- get bh
occ <- return $! mkOccNameFS tcName a1
- return (IfaceAxiom occ a2 a3)
+ return (IfaceAxiom occ a2 a3 a4)
data IfaceSynTyConRhs
= IfaceOpenSynFamilyTyCon
@@ -282,22 +294,25 @@ pprAxBranch mtycon (IfaceAxBranch { ifaxbTyVars = tvs
-- this is just like CoAxBranch
data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
, ifaxbLHS :: [IfaceType]
+ , ifaxbRoles :: [Role]
, ifaxbRHS :: IfaceType
, ifaxbIncomps :: [BranchIndex] }
-- See Note [Storing compatibility] in CoAxiom
instance Binary IfaceAxBranch where
- put_ bh (IfaceAxBranch a1 a2 a3 a4) = do
+ put_ bh (IfaceAxBranch a1 a2 a3 a4 a5) = do
put_ bh a1
put_ bh a2
put_ bh a3
put_ bh a4
+ put_ bh a5
get bh = do
a1 <- get bh
a2 <- get bh
a3 <- get bh
a4 <- get bh
- return (IfaceAxBranch a1 a2 a3 a4)
+ a5 <- get bh
+ return (IfaceAxBranch a1 a2 a3 a4 a5)
data IfaceConDecls
= IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon
@@ -625,7 +640,7 @@ data IfaceExpr
= IfaceLcl IfLclName
| IfaceExt IfExtName
| IfaceType IfaceType
- | IfaceCo IfaceType -- We re-use IfaceType for coercions
+ | IfaceCo IfaceCoercion
| IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
@@ -1010,26 +1025,27 @@ pprIfaceDecl (IfaceForeign {ifName = tycon})
pprIfaceDecl (IfaceSyn {ifName = tycon,
ifTyVars = tyvars,
+ ifRoles = roles,
ifSynRhs = IfaceSynonymTyCon mono_ty})
- = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
+ = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars roles)
4 (vcat [equals <+> ppr mono_ty])
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles,
ifSynRhs = IfaceOpenSynFamilyTyCon, ifSynKind = kind })
- = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
+ = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars roles)
4 (dcolon <+> ppr kind)
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles,
ifSynRhs = IfaceClosedSynFamilyTyCon {}, ifSynKind = kind })
- = hang (ptext (sLit "closed type family") <+> pprIfaceDeclHead [] tycon tyvars)
+ = hang (ptext (sLit "closed type family") <+> pprIfaceDeclHead [] tycon tyvars roles)
4 (dcolon <+> ppr kind)
pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
ifCtxt = context,
- ifTyVars = tyvars, ifCons = condecls,
+ ifTyVars = tyvars, ifRoles = roles, ifCons = condecls,
ifRec = isrec, ifPromotable = is_prom,
ifAxiom = mbAxiom})
- = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
+ = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars roles)
4 (vcat [ pprCType cType
, pprRec isrec <> comma <+> pp_prom
, pp_condecls tycon condecls
@@ -1044,9 +1060,9 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
IfNewTyCon _ -> ptext (sLit "newtype")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
- ifFDs = fds, ifATs = ats, ifSigs = sigs,
+ ifRoles = roles, ifFDs = fds, ifATs = ats, ifSigs = sigs,
ifRec = isrec})
- = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
+ = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars roles <+> pprFundeps fds)
4 (vcat [pprRec isrec,
sep (map ppr ats),
sep (map ppr sigs)])
@@ -1072,10 +1088,10 @@ instance Outputable IfaceClassOp where
instance Outputable IfaceAT where
ppr (IfaceAT d defs) = hang (ppr d) 2 (vcat (map ppr defs))
-pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
-pprIfaceDeclHead context thing tyvars
+pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> [Role] -> SDoc
+pprIfaceDeclHead context thing tyvars roles
= hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
- pprIfaceTvBndrs tyvars]
+ pprIfaceTvBndrsRoles tyvars roles]
pp_condecls :: OccName -> IfaceConDecls -> SDoc
pp_condecls _ (IfAbstractTyCon {}) = empty
@@ -1105,7 +1121,7 @@ pprIfaceConDecl tc
ppr_bang IfNoBang = char '_' -- Want to see these
ppr_bang IfStrict = char '!'
ppr_bang IfUnpack = ptext (sLit "!!")
- ppr_bang (IfUnpackCo co) = ptext (sLit "!!") <> pprParendIfaceType co
+ ppr_bang (IfUnpackCo co) = ptext (sLit "!!") <> pprParendIfaceCoercion co
main_payload = ppr name <+> dcolon <+>
pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
@@ -1170,7 +1186,7 @@ pprIfaceExpr _ (IfaceExt v) = ppr v
pprIfaceExpr _ (IfaceLit l) = ppr l
pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty
-pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceType co
+pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co
pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as)
@@ -1203,7 +1219,7 @@ pprIfaceExpr add_par (IfaceCase scrut bndr alts)
pprIfaceExpr _ (IfaceCast expr co)
= sep [pprParendIfaceExpr expr,
nest 2 (ptext (sLit "`cast`")),
- pprParendIfaceType co]
+ pprParendIfaceCoercion co]
pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
= add_par (sep [ptext (sLit "let {"),
@@ -1376,8 +1392,35 @@ freeNamesIfType (IfaceLitTy _) = emptyNameSet
freeNamesIfType (IfaceForAllTy tv t) =
freeNamesIfTvBndr tv &&& freeNamesIfType t
freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
-freeNamesIfType (IfaceCoConApp tc ts) =
- freeNamesIfCo tc &&& fnList freeNamesIfType ts
+
+freeNamesIfCoercion :: IfaceCoercion -> NameSet
+freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t
+freeNamesIfCoercion (IfaceFunCo _ c1 c2)
+ = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
+freeNamesIfCoercion (IfaceTyConAppCo _ tc cos)
+ = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos
+freeNamesIfCoercion (IfaceAppCo c1 c2)
+ = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
+freeNamesIfCoercion (IfaceForAllCo tv co)
+ = freeNamesIfTvBndr tv &&& freeNamesIfCoercion co
+freeNamesIfCoercion (IfaceCoVarCo _)
+ = emptyNameSet
+freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos)
+ = unitNameSet ax &&& fnList freeNamesIfCoercion cos
+freeNamesIfCoercion (IfaceUnivCo _ t1 t2)
+ = freeNamesIfType t1 &&& freeNamesIfType t2
+freeNamesIfCoercion (IfaceSymCo c)
+ = freeNamesIfCoercion c
+freeNamesIfCoercion (IfaceTransCo c1 c2)
+ = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
+freeNamesIfCoercion (IfaceNthCo _ co)
+ = freeNamesIfCoercion co
+freeNamesIfCoercion (IfaceLRCo _ co)
+ = freeNamesIfCoercion co
+freeNamesIfCoercion (IfaceInstCo co ty)
+ = freeNamesIfCoercion co &&& freeNamesIfType ty
+freeNamesIfCoercion (IfaceSubCo co)
+ = freeNamesIfCoercion co
freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet
freeNamesIfTvBndrs = fnList freeNamesIfTvBndr
@@ -1420,11 +1463,11 @@ freeNamesIfExpr :: IfaceExpr -> NameSet
freeNamesIfExpr (IfaceExt v) = unitNameSet v
freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty
-freeNamesIfExpr (IfaceCo co) = freeNamesIfType co
+freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co
freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body
freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
-freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co
+freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co
freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e
freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
freeNamesIfExpr (IfaceCase s _ alts)
@@ -1454,11 +1497,6 @@ freeNamesIfTc :: IfaceTyCon -> NameSet
freeNamesIfTc (IfaceTc tc) = unitNameSet tc
-- ToDo: shouldn't we include IfaceIntTc & co.?
-freeNamesIfCo :: IfaceCoCon -> NameSet
-freeNamesIfCo (IfaceCoAx tc _) = unitNameSet tc
--- ToDo: include IfaceIPCoAx? Probably not necessary.
-freeNamesIfCo _ = emptyNameSet
-
freeNamesIfRule :: IfaceRule -> NameSet
freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
, ifRuleArgs = es, ifRuleRhs = rhs })
diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index c3b59b7be8..b9d6a445cf 100644
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -9,22 +9,24 @@ This module defines interface types and binders
module IfaceType (
IfExtName, IfLclName,
- IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoCon(..),
+ IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoercion(..),
IfaceTyLit(..),
- IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
+ IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr,
-- Conversion from Type -> IfaceType
toIfaceType, toIfaceKind, toIfaceContext,
toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs,
toIfaceTyCon, toIfaceTyCon_name,
- -- Conversion from Coercion -> IfaceType
- coToIfaceType,
+ -- Conversion from Coercion -> IfaceCoercion
+ toIfaceCoercion,
-- Printing
pprIfaceType, pprParendIfaceType, pprIfaceContext,
- pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs,
- tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart
+ pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceTvBndrsRoles,
+ pprIfaceBndrs,
+ tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart,
+ pprIfaceCoercion, pprParendIfaceCoercion
) where
@@ -68,16 +70,14 @@ type IfaceTvBndr = (IfLclName, IfaceKind)
-------------------------------
type IfaceKind = IfaceType
-type IfaceCoercion = IfaceType
-data IfaceType -- A kind of universal type, used for types, kinds, and coercions
+data IfaceType -- A kind of universal type, used for types and kinds
= IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
| IfaceAppTy IfaceType IfaceType
| IfaceFunTy IfaceType IfaceType
| IfaceForAllTy IfaceTvBndr IfaceType
| IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated
-- Includes newtypes, synonyms, tuples
- | IfaceCoConApp IfaceCoCon [IfaceType] -- Always saturated
| IfaceLitTy IfaceTyLit
type IfacePredType = IfaceType
@@ -91,12 +91,21 @@ data IfaceTyLit
-- coercion constructors, the lot
newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName }
- -- Coercion constructors
-data IfaceCoCon
- = IfaceCoAx IfExtName BranchIndex -- BranchIndex is 0-indexed branch number
- | IfaceReflCo | IfaceUnsafeCo | IfaceSymCo
- | IfaceTransCo | IfaceInstCo
- | IfaceNthCo Int | IfaceLRCo LeftOrRight
+data IfaceCoercion
+ = IfaceReflCo Role IfaceType
+ | IfaceFunCo Role IfaceCoercion IfaceCoercion
+ | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion]
+ | IfaceAppCo IfaceCoercion IfaceCoercion
+ | IfaceForAllCo IfaceTvBndr IfaceCoercion
+ | IfaceCoVarCo IfLclName
+ | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion]
+ | IfaceUnivCo Role IfaceType IfaceType
+ | IfaceSymCo IfaceCoercion
+ | IfaceTransCo IfaceCoercion IfaceCoercion
+ | IfaceNthCo Int IfaceCoercion
+ | IfaceLRCo LeftOrRight IfaceCoercion
+ | IfaceInstCo IfaceCoercion IfaceType
+ | IfaceSubCo IfaceCoercion
\end{code}
%************************************************************************
@@ -177,6 +186,11 @@ pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars)
+pprIfaceTvBndrsRoles :: [IfaceTvBndr] -> [Role] -> SDoc
+pprIfaceTvBndrsRoles tyvars roles = sep (zipWith ppr_bndr_role tyvars roles)
+ where
+ ppr_bndr_role bndr role = pprIfaceTvBndr bndr <> char '@' <> ppr role
+
instance Binary IfaceBndr where
put_ bh (IfaceIdBndr aa) = do
putByte bh 0
@@ -211,14 +225,10 @@ isIfacePredTy _ = False
ppr_ty :: Int -> IfaceType -> SDoc
ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar
-ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
+ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ppr_ty ctxt_prec tc tys
ppr_ty _ (IfaceLitTy n) = ppr_tylit n
-ppr_ty ctxt_prec (IfaceCoConApp tc tys)
- = maybeParen ctxt_prec tYCON_PREC
- (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))])
-
-- Function types
ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
= -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
@@ -243,7 +253,9 @@ ppr_ty ctxt_prec ty@(IfaceForAllTy _ _)
(tvs, theta, tau) = splitIfaceSigmaTy ty
-------------------
-pprIfaceForAllPart :: [IfaceTvBndr] -> IfaceContext -> SDoc -> SDoc
+-- needs to handle type contexts and coercion contexts, hence the
+-- generality
+pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc
pprIfaceForAllPart tvs ctxt doc
= sep [ppr_tvs, pprIfaceContext ctxt, doc]
where
@@ -251,20 +263,23 @@ pprIfaceForAllPart tvs ctxt doc
| otherwise = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
-------------------
-ppr_tc_app :: Int -> IfaceTyCon -> [IfaceType] -> SDoc
-ppr_tc_app _ tc [] = ppr_tc tc
+ppr_tc_app :: (Int -> a -> SDoc) -> Int -> IfaceTyCon -> [a] -> SDoc
+ppr_tc_app _ _ tc [] = ppr_tc tc
-ppr_tc_app _ (IfaceTc n) [ty] | n == listTyConName = brackets (pprIfaceType ty)
-ppr_tc_app _ (IfaceTc n) [ty] | n == parrTyConName = paBrackets (pprIfaceType ty)
-ppr_tc_app _ (IfaceTc n) tys
+ppr_tc_app pp _ (IfaceTc n) [ty]
+ | n == listTyConName
+ = brackets (pp tOP_PREC ty)
+ | n == parrTyConName
+ = paBrackets (pp tOP_PREC ty)
+ppr_tc_app pp _ (IfaceTc n) tys
| Just (ATyCon tc) <- wiredInNameTyThing_maybe n
, Just sort <- tyConTuple_maybe tc
, tyConArity tc == length tys
- = tupleParens sort (sep (punctuate comma (map pprIfaceType tys)))
-ppr_tc_app ctxt_prec tc tys
+ = tupleParens sort (sep (punctuate comma (map (pp tOP_PREC) tys)))
+ppr_tc_app pp ctxt_prec tc tys
= maybeParen ctxt_prec tYCON_PREC
- (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))])
+ (sep [ppr_tc tc, nest 4 (sep (map (pp tYCON_PREC) tys))])
ppr_tc :: IfaceTyCon -> SDoc
-- Wrap infix type constructors in parens
@@ -278,47 +293,78 @@ ppr_tylit :: IfaceTyLit -> SDoc
ppr_tylit (IfaceNumTyLit n) = integer n
ppr_tylit (IfaceStrTyLit n) = text (show n)
+pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
+pprIfaceCoercion = ppr_co tOP_PREC
+pprParendIfaceCoercion = ppr_co tYCON_PREC
+
+ppr_co :: Int -> IfaceCoercion -> SDoc
+ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r
+ppr_co ctxt_prec (IfaceFunCo r co1 co2)
+ = maybeParen ctxt_prec fUN_PREC $
+ sep (ppr_co fUN_PREC co1 : ppr_fun_tail co2)
+ where
+ ppr_fun_tail (IfaceFunCo r co1 co2)
+ = (arrow <> ppr_role r <+> ppr_co fUN_PREC co1) : ppr_fun_tail co2
+ ppr_fun_tail other_co
+ = [arrow <> ppr_role r <+> pprIfaceCoercion other_co]
+
+ppr_co _ (IfaceTyConAppCo r tc cos)
+ = parens (ppr_tc_app ppr_co tOP_PREC tc cos) <> ppr_role r
+ppr_co ctxt_prec (IfaceAppCo co1 co2)
+ = maybeParen ctxt_prec tYCON_PREC $
+ ppr_co fUN_PREC co1 <+> pprParendIfaceCoercion co2
+ppr_co ctxt_prec co@(IfaceForAllCo _ _)
+ = maybeParen ctxt_prec fUN_PREC (sep [ppr_tvs, pprIfaceCoercion inner_co])
+ where
+ (tvs, inner_co) = split_co co
+ ppr_tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
+
+ split_co (IfaceForAllCo tv co')
+ = let (tvs, co'') = split_co co' in (tv:tvs,co'')
+ split_co co' = ([], co')
+
+ppr_co _ (IfaceCoVarCo covar) = ppr covar
+
+ppr_co ctxt_prec (IfaceUnivCo r ty1 ty2)
+ = maybeParen ctxt_prec tYCON_PREC $
+ ptext (sLit "UnivCo") <+> ppr r <+>
+ pprParendIfaceType ty1 <+> pprParendIfaceType ty2
+
+ppr_co ctxt_prec (IfaceInstCo co ty)
+ = maybeParen ctxt_prec tYCON_PREC $
+ ptext (sLit "Inst") <+> pprParendIfaceCoercion co <+> pprParendIfaceType ty
+
+ppr_co ctxt_prec co
+ = ppr_special_co ctxt_prec doc cos
+ where (doc, cos) = case co of
+ { IfaceAxiomInstCo n i cos -> (ppr n <> brackets (ppr i), cos)
+ ; IfaceSymCo co -> (ptext (sLit "Sym"), [co])
+ ; IfaceTransCo co1 co2 -> (ptext (sLit "Trans"), [co1,co2])
+ ; IfaceNthCo d co -> (ptext (sLit "Nth:") <> int d,
+ [co])
+ ; IfaceLRCo lr co -> (ppr lr, [co])
+ ; IfaceSubCo co -> (ptext (sLit "Sub"), [co])
+ ; _ -> panic "pprIfaceCo" }
+
+ppr_special_co :: Int -> SDoc -> [IfaceCoercion] -> SDoc
+ppr_special_co ctxt_prec doc cos
+ = maybeParen ctxt_prec tYCON_PREC
+ (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
+
+ppr_role :: Role -> SDoc
+ppr_role r = underscore <> ppr r
+
-------------------
instance Outputable IfaceTyCon where
ppr = ppr . ifaceTyConName
+instance Outputable IfaceCoercion where
+ ppr = pprIfaceCoercion
+
instance Binary IfaceTyCon where
put_ bh (IfaceTc ext) = put_ bh ext
get bh = liftM IfaceTc (get bh)
-instance Outputable IfaceCoCon where
- ppr (IfaceCoAx n i) = ppr n <> brackets (ppr i)
- ppr IfaceReflCo = ptext (sLit "Refl")
- ppr IfaceUnsafeCo = ptext (sLit "Unsafe")
- ppr IfaceSymCo = ptext (sLit "Sym")
- ppr IfaceTransCo = ptext (sLit "Trans")
- ppr IfaceInstCo = ptext (sLit "Inst")
- ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d
- ppr (IfaceLRCo lr) = ppr lr
-
-instance Binary IfaceCoCon where
- put_ bh (IfaceCoAx n ind) = do { putByte bh 0; put_ bh n; put_ bh ind }
- put_ bh IfaceReflCo = putByte bh 1
- put_ bh IfaceUnsafeCo = putByte bh 2
- put_ bh IfaceSymCo = putByte bh 3
- put_ bh IfaceTransCo = putByte bh 4
- put_ bh IfaceInstCo = putByte bh 5
- put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d }
- put_ bh (IfaceLRCo lr) = do { putByte bh 7; put_ bh lr }
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do { n <- get bh; ind <- get bh; return (IfaceCoAx n ind) }
- 1 -> return IfaceReflCo
- 2 -> return IfaceUnsafeCo
- 3 -> return IfaceSymCo
- 4 -> return IfaceTransCo
- 5 -> return IfaceInstCo
- 6 -> do { d <- get bh; return (IfaceNthCo d) }
- 7 -> do { lr <- get bh; return (IfaceLRCo lr) }
- _ -> panic ("get IfaceCoCon " ++ show h)
-
instance Outputable IfaceTyLit where
ppr = ppr_tylit
@@ -336,12 +382,12 @@ instance Binary IfaceTyLit where
_ -> panic ("get IfaceTyLit " ++ show tag)
-------------------
-pprIfaceContext :: IfaceContext -> SDoc
+pprIfaceContext :: Outputable a => [a] -> SDoc
-- Prints "(C a, D b) =>", including the arrow
pprIfaceContext [] = empty
pprIfaceContext theta = ppr_preds theta <+> darrow
-ppr_preds :: [IfacePredType] -> SDoc
+ppr_preds :: Outputable a => [a] -> SDoc
ppr_preds [pred] = ppr pred -- No parens
ppr_preds preds = parens (sep (punctuate comma (map ppr preds)))
@@ -361,8 +407,6 @@ instance Binary IfaceType where
putByte bh 3
put_ bh ag
put_ bh ah
- put_ bh (IfaceCoConApp cc tys)
- = do { putByte bh 4; put_ bh cc; put_ bh tys }
put_ bh (IfaceTyConApp tc tys)
= do { putByte bh 5; put_ bh tc; put_ bh tys }
@@ -383,8 +427,6 @@ instance Binary IfaceType where
3 -> do ag <- get bh
ah <- get bh
return (IfaceFunTy ag ah)
- 4 -> do { cc <- get bh; tys <- get bh
- ; return (IfaceCoConApp cc tys) }
5 -> do { tc <- get bh; tys <- get bh
; return (IfaceTyConApp tc tys) }
@@ -392,6 +434,114 @@ instance Binary IfaceType where
return (IfaceLitTy n)
_ -> panic ("get IfaceType " ++ show h)
+
+instance Binary IfaceCoercion where
+ put_ bh (IfaceReflCo a b) = do
+ putByte bh 1
+ put_ bh a
+ put_ bh b
+ put_ bh (IfaceFunCo a b c) = do
+ putByte bh 2
+ put_ bh a
+ put_ bh b
+ put_ bh c
+ put_ bh (IfaceTyConAppCo a b c) = do
+ putByte bh 3
+ put_ bh a
+ put_ bh b
+ put_ bh c
+ put_ bh (IfaceAppCo a b) = do
+ putByte bh 4
+ put_ bh a
+ put_ bh b
+ put_ bh (IfaceForAllCo a b) = do
+ putByte bh 5
+ put_ bh a
+ put_ bh b
+ put_ bh (IfaceCoVarCo a) = do
+ putByte bh 6
+ put_ bh a
+ put_ bh (IfaceAxiomInstCo a b c) = do
+ putByte bh 7
+ put_ bh a
+ put_ bh b
+ put_ bh c
+ put_ bh (IfaceUnivCo a b c) = do
+ putByte bh 8
+ put_ bh a
+ put_ bh b
+ put_ bh c
+ put_ bh (IfaceSymCo a) = do
+ putByte bh 9
+ put_ bh a
+ put_ bh (IfaceTransCo a b) = do
+ putByte bh 10
+ put_ bh a
+ put_ bh b
+ put_ bh (IfaceNthCo a b) = do
+ putByte bh 11
+ put_ bh a
+ put_ bh b
+ put_ bh (IfaceLRCo a b) = do
+ putByte bh 12
+ put_ bh a
+ put_ bh b
+ put_ bh (IfaceInstCo a b) = do
+ putByte bh 13
+ put_ bh a
+ put_ bh b
+ put_ bh (IfaceSubCo a) = do
+ putByte bh 14
+ put_ bh a
+
+ get bh = do
+ tag <- getByte bh
+ case tag of
+ 1 -> do a <- get bh
+ b <- get bh
+ return $ IfaceReflCo a b
+ 2 -> do a <- get bh
+ b <- get bh
+ c <- get bh
+ return $ IfaceFunCo a b c
+ 3 -> do a <- get bh
+ b <- get bh
+ c <- get bh
+ return $ IfaceTyConAppCo a b c
+ 4 -> do a <- get bh
+ b <- get bh
+ return $ IfaceAppCo a b
+ 5 -> do a <- get bh
+ b <- get bh
+ return $ IfaceForAllCo a b
+ 6 -> do a <- get bh
+ return $ IfaceCoVarCo a
+ 7 -> do a <- get bh
+ b <- get bh
+ c <- get bh
+ return $ IfaceAxiomInstCo a b c
+ 8 -> do a <- get bh
+ b <- get bh
+ c <- get bh
+ return $ IfaceUnivCo a b c
+ 9 -> do a <- get bh
+ return $ IfaceSymCo a
+ 10-> do a <- get bh
+ b <- get bh
+ return $ IfaceTransCo a b
+ 11-> do a <- get bh
+ b <- get bh
+ return $ IfaceNthCo a b
+ 12-> do a <- get bh
+ b <- get bh
+ return $ IfaceLRCo a b
+ 13-> do a <- get bh
+ b <- get bh
+ return $ IfaceInstCo a b
+ 14-> do a <- get bh
+ return $ IfaceSubCo a
+ _ -> panic ("get IfaceCoercion " ++ show tag)
+
\end{code}
%************************************************************************
@@ -453,38 +603,31 @@ toIfaceContext :: ThetaType -> IfaceContext
toIfaceContext = toIfaceTypes
----------------
-coToIfaceType :: Coercion -> IfaceType
-coToIfaceType (Refl ty) = IfaceCoConApp IfaceReflCo [toIfaceType ty]
-coToIfaceType (TyConAppCo tc cos)
+toIfaceCoercion :: Coercion -> IfaceCoercion
+toIfaceCoercion (Refl r ty) = IfaceReflCo r (toIfaceType ty)
+toIfaceCoercion (TyConAppCo r tc cos)
| tc `hasKey` funTyConKey
- , [arg,res] <- cos = IfaceFunTy (coToIfaceType arg) (coToIfaceType res)
- | otherwise = IfaceTyConApp (toIfaceTyCon tc)
- (map coToIfaceType cos)
-coToIfaceType (AppCo co1 co2) = IfaceAppTy (coToIfaceType co1)
- (coToIfaceType co2)
-coToIfaceType (ForAllCo v co) = IfaceForAllTy (toIfaceTvBndr v)
- (coToIfaceType co)
-coToIfaceType (CoVarCo cv) = IfaceTyVar (toIfaceCoVar cv)
-coToIfaceType (AxiomInstCo con ind cos)
- = IfaceCoConApp (coAxiomToIfaceType con ind)
- (map coToIfaceType cos)
-coToIfaceType (UnsafeCo ty1 ty2) = IfaceCoConApp IfaceUnsafeCo
- [ toIfaceType ty1
- , toIfaceType ty2 ]
-coToIfaceType (SymCo co) = IfaceCoConApp IfaceSymCo
- [ coToIfaceType co ]
-coToIfaceType (TransCo co1 co2) = IfaceCoConApp IfaceTransCo
- [ coToIfaceType co1
- , coToIfaceType co2 ]
-coToIfaceType (NthCo d co) = IfaceCoConApp (IfaceNthCo d)
- [ coToIfaceType co ]
-coToIfaceType (LRCo lr co) = IfaceCoConApp (IfaceLRCo lr)
- [ coToIfaceType co ]
-coToIfaceType (InstCo co ty) = IfaceCoConApp IfaceInstCo
- [ coToIfaceType co
- , toIfaceType ty ]
-
-coAxiomToIfaceType :: CoAxiom br -> Int -> IfaceCoCon
-coAxiomToIfaceType con ind = IfaceCoAx (coAxiomName con) ind
+ , [arg,res] <- cos = IfaceFunCo r (toIfaceCoercion arg) (toIfaceCoercion res)
+ | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc)
+ (map toIfaceCoercion cos)
+toIfaceCoercion (AppCo co1 co2) = IfaceAppCo (toIfaceCoercion co1)
+ (toIfaceCoercion co2)
+toIfaceCoercion (ForAllCo v co) = IfaceForAllCo (toIfaceTvBndr v)
+ (toIfaceCoercion co)
+toIfaceCoercion (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv)
+toIfaceCoercion (AxiomInstCo con ind cos)
+ = IfaceAxiomInstCo (coAxiomName con) ind
+ (map toIfaceCoercion cos)
+toIfaceCoercion (UnivCo r ty1 ty2) = IfaceUnivCo r (toIfaceType ty1)
+ (toIfaceType ty2)
+toIfaceCoercion (SymCo co) = IfaceSymCo (toIfaceCoercion co)
+toIfaceCoercion (TransCo co1 co2) = IfaceTransCo (toIfaceCoercion co1)
+ (toIfaceCoercion co2)
+toIfaceCoercion (NthCo d co) = IfaceNthCo d (toIfaceCoercion co)
+toIfaceCoercion (LRCo lr co) = IfaceLRCo lr (toIfaceCoercion co)
+toIfaceCoercion (InstCo co ty) = IfaceInstCo (toIfaceCoercion co)
+ (toIfaceType ty)
+toIfaceCoercion (SubCo co) = IfaceSubCo (toIfaceCoercion co)
+
\end{code}
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index d9bd6fc941..bf48f889a4 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1441,9 +1441,11 @@ idToIfaceDecl id
coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
-- We *do* tidy Axioms, because they are not (and cannot
-- conveniently be) built in tidy form
-coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches })
+coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
+ , co_ax_role = role })
= IfaceAxiom { ifName = name
, ifTyCon = toIfaceTyCon tycon
+ , ifRole = role
, ifAxBranches = brListMap (coAxBranchToIfaceBranch
emptyTidyEnv
(brListMap coAxBranchLHS branches)) branches }
@@ -1466,9 +1468,11 @@ coAxBranchToIfaceBranch env0 lhs_s
-- use this one for standalone branches without incompatibles
coAxBranchToIfaceBranch' :: TidyEnv -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch' env0
- (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs })
+ (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs
+ , cab_roles = roles, cab_rhs = rhs })
= IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs
, ifaxbLHS = map (tidyToIfaceType env1) lhs
+ , ifaxbRoles = roles
, ifaxbRHS = tidyToIfaceType env1 rhs
, ifaxbIncomps = [] }
where
@@ -1485,6 +1489,7 @@ tyConToIfaceDecl env tycon
| Just syn_rhs <- synTyConRhs_maybe tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
+ ifRoles = tyConRoles tycon,
ifSynRhs = to_ifsyn_rhs syn_rhs,
ifSynKind = tidyToIfaceType env1 (synTyConResKind tycon) }
@@ -1492,6 +1497,7 @@ tyConToIfaceDecl env tycon
= IfaceData { ifName = getOccName tycon,
ifCType = tyConCType tycon,
ifTyVars = toIfaceTvBndrs tyvars,
+ ifRoles = tyConRoles tycon,
ifCtxt = tidyToIfaceContext env1 (tyConStupidTheta tycon),
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
@@ -1545,7 +1551,7 @@ tyConToIfaceDecl env tycon
toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
toIfaceBang _ HsNoBang = IfNoBang
toIfaceBang _ (HsUnpack Nothing) = IfUnpack
-toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (coToIfaceType (tidyCo env co))
+toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
toIfaceBang _ HsStrict = IfStrict
toIfaceBang _ (HsUserBang {}) = panic "toIfaceBang"
@@ -1554,6 +1560,7 @@ classToIfaceDecl env clas
= IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta,
ifName = getOccName (classTyCon clas),
ifTyVars = toIfaceTvBndrs clas_tyvars',
+ ifRoles = tyConRoles (classTyCon clas),
ifFDs = map toIfaceFD clas_fds,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
@@ -1790,7 +1797,7 @@ coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn,
-- construct the same ru_rough field as we have right now;
-- see tcIfaceRule
do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
- do_arg (Coercion co) = IfaceCo (coToIfaceType co)
+ do_arg (Coercion co) = IfaceCo (toIfaceCoercion co)
do_arg arg = toIfaceExpr arg
-- Compute orphanhood. See Note [Orphans] in IfaceSyn
@@ -1813,14 +1820,14 @@ toIfaceExpr :: CoreExpr -> IfaceExpr
toIfaceExpr (Var v) = toIfaceVar v
toIfaceExpr (Lit l) = IfaceLit l
toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
-toIfaceExpr (Coercion co) = IfaceCo (coToIfaceType co)
+toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co)
toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
toIfaceExpr (App f a) = toIfaceApp f [a]
toIfaceExpr (Case s x ty as)
| null as = IfaceECase (toIfaceExpr s) (toIfaceType ty)
| otherwise = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
-toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (coToIfaceType co)
+toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)
toIfaceExpr (Tick t e) = IfaceTick (toIfaceTickish t) (toIfaceExpr e)
---------------------
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index f6b4e40fd7..c379199214 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -437,7 +437,8 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
tc_iface_decl parent _ (IfaceData {ifName = occ_name,
ifCType = cType,
- ifTyVars = tv_bndrs,
+ ifTyVars = tv_bndrs,
+ ifRoles = roles,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec, ifPromotable = is_prom,
@@ -448,7 +449,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
{ stupid_theta <- tcIfaceCtxt ctxt
; parent' <- tc_parent tyvars mb_axiom_name
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
- ; return (buildAlgTyCon tc_name tyvars cType stupid_theta
+ ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta
cons is_rec is_prom gadt_syn parent') }
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
@@ -479,6 +480,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
; return (FamInstTyCon ax_unbr fam_tc lhs_tys) }
tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
+ ifRoles = roles,
ifSynRhs = mb_rhs_ty,
ifSynKind = kind })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
@@ -486,7 +488,7 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop]
; rhs <- forkM (mk_doc tc_name) $
tc_syn_rhs mb_rhs_ty
- ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent
+ ; tycon <- buildSynTyCon tc_name tyvars roles rhs rhs_kind parent
; return (ATyCon tycon) }
where
mk_doc n = ptext (sLit "Type syonym") <+> ppr n
@@ -499,7 +501,7 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
tc_iface_decl _parent ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
- ifTyVars = tv_bndrs, ifFDs = rdr_fds,
+ ifTyVars = tv_bndrs, ifRoles = roles, ifFDs = rdr_fds,
ifATs = rdr_ats, ifSigs = rdr_sigs,
ifRec = tc_isrec })
-- ToDo: in hs-boot files we should really treat abstract classes specially,
@@ -515,7 +517,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 ignore_prags tc_name tyvars ctxt fds ats sigs tc_isrec }
+ ; buildClass ignore_prags tc_name tyvars roles ctxt fds ats sigs tc_isrec }
; return (ATyCon (classTyCon cls)) }
where
tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
@@ -555,9 +557,10 @@ tc_iface_decl _parent ignore_prags
tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
= do { name <- lookupIfaceTop rdr_name
; return (ATyCon (mkForeignTyCon name ext_name
- liftedTypeKind 0)) }
+ liftedTypeKind)) }
-tc_iface_decl _ _ (IfaceAxiom {ifName = ax_occ, ifTyCon = tc, ifAxBranches = branches})
+tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
+ , ifAxBranches = branches, ifRole = role })
= do { tc_name <- lookupIfaceTop ax_occ
; tc_tycon <- tcIfaceTyCon tc
; tc_branches <- foldlM tc_ax_branches [] branches
@@ -565,6 +568,7 @@ tc_iface_decl _ _ (IfaceAxiom {ifName = ax_occ, ifTyCon = tc, ifAxBranches = bra
CoAxiom { co_ax_unique = nameUnique tc_name
, co_ax_name = tc_name
, co_ax_tc = tc_tycon
+ , co_ax_role = role
, co_ax_branches = toBranchList tc_branches
, co_ax_implicit = False }
; return (ACoAxiom axiom) }
@@ -572,14 +576,15 @@ tc_iface_decl _ _ (IfaceAxiom {ifName = ax_occ, ifTyCon = tc, ifAxBranches = bra
tc_ax_branches :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
tc_ax_branches prev_branches
(IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs
- , ifaxbIncomps = incomps })
+ , ifaxbRoles = roles, ifaxbIncomps = incomps })
= bindIfaceTyVars tv_bndrs $ \ tvs -> do -- Variables will all be fresh
{ tc_lhs <- mapM tcIfaceType lhs
; tc_rhs <- tcIfaceType rhs
- ; let br = CoAxBranch { cab_loc = noSrcSpan
- , cab_tvs = tvs
- , cab_lhs = tc_lhs
- , cab_rhs = tc_rhs
+ ; let br = CoAxBranch { cab_loc = noSrcSpan
+ , cab_tvs = tvs
+ , cab_lhs = tc_lhs
+ , cab_roles = roles
+ , cab_rhs = tc_rhs
, cab_incomps = map (prev_branches !!) incomps }
; return (prev_branches ++ [br]) }
@@ -915,7 +920,6 @@ tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc
; tks' <- tcIfaceTcArgs (tyConKind tc') tks
; return (mkTyConApp tc' tks') }
tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
-tcIfaceType t@(IfaceCoConApp {}) = pprPanic "tcIfaceType" (ppr t)
tcIfaceTypes :: [IfaceType] -> IfL [Type]
tcIfaceTypes tys = mapM tcIfaceType tys
@@ -983,28 +987,29 @@ This context business is why we need tcIfaceTcArgs.
%************************************************************************
\begin{code}
-tcIfaceCo :: IfaceType -> IfL Coercion
-tcIfaceCo (IfaceTyVar n) = mkCoVarCo <$> tcIfaceCoVar n
-tcIfaceCo (IfaceAppTy t1 t2) = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
-tcIfaceCo (IfaceFunTy t1 t2) = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
-tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts
-tcIfaceCo t@(IfaceLitTy _) = mkReflCo <$> tcIfaceType t
-tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts
-tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' ->
- mkForAllCo tv' <$> tcIfaceCo t
-
-tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion
-tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t
-tcIfaceCoApp (IfaceCoAx n i) ts = AxiomInstCo <$> tcIfaceCoAxiom n
- <*> pure i
- <*> mapM tcIfaceCo ts
-tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2
-tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t
-tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
-tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2
-tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t
-tcIfaceCoApp (IfaceLRCo lr) [t] = LRCo lr <$> tcIfaceCo t
-tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts)
+tcIfaceCo :: IfaceCoercion -> IfL Coercion
+tcIfaceCo (IfaceReflCo r t) = mkReflCo r <$> tcIfaceType t
+tcIfaceCo (IfaceFunCo r c1 c2) = mkFunCo r <$> tcIfaceCo c1 <*> tcIfaceCo c2
+tcIfaceCo (IfaceTyConAppCo r tc cs) = mkTyConAppCo r <$> tcIfaceTyCon tc
+ <*> mapM tcIfaceCo cs
+tcIfaceCo (IfaceAppCo c1 c2) = mkAppCo <$> tcIfaceCo c1
+ <*> tcIfaceCo c2
+tcIfaceCo (IfaceForAllCo tv c) = bindIfaceTyVar tv $ \ tv' ->
+ mkForAllCo tv' <$> tcIfaceCo c
+tcIfaceCo (IfaceCoVarCo n) = mkCoVarCo <$> tcIfaceCoVar n
+tcIfaceCo (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n
+ <*> pure i
+ <*> mapM tcIfaceCo cs
+tcIfaceCo (IfaceUnivCo r t1 t2) = UnivCo r <$> tcIfaceType t1
+ <*> tcIfaceType t2
+tcIfaceCo (IfaceSymCo c) = SymCo <$> tcIfaceCo c
+tcIfaceCo (IfaceTransCo c1 c2) = TransCo <$> tcIfaceCo c1
+ <*> tcIfaceCo c2
+tcIfaceCo (IfaceInstCo c1 t2) = InstCo <$> tcIfaceCo c1
+ <*> tcIfaceType t2
+tcIfaceCo (IfaceNthCo d c) = NthCo d <$> tcIfaceCo c
+tcIfaceCo (IfaceLRCo lr c) = LRCo lr <$> tcIfaceCo c
+tcIfaceCo (IfaceSubCo c) = SubCo <$> tcIfaceCo c
tcIfaceCoVar :: FastString -> IfL CoVar
tcIfaceCoVar = tcIfaceLclId
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 0bbd819a79..64ec8be612 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -535,6 +535,7 @@ data ExtensionFlag
| Opt_MagicHash
| Opt_EmptyDataDecls
| Opt_KindSignatures
+ | Opt_RoleAnnotations
| Opt_ParallelListComp
| Opt_TransformListComp
| Opt_MonadComprehensions
@@ -2637,6 +2638,7 @@ xFlags = [
( "MagicHash", Opt_MagicHash, nop ),
( "ExistentialQuantification", Opt_ExistentialQuantification, nop ),
( "KindSignatures", Opt_KindSignatures, nop ),
+ ( "RoleAnnotations", Opt_RoleAnnotations, nop ),
( "EmptyDataDecls", Opt_EmptyDataDecls, nop ),
( "ParallelListComp", Opt_ParallelListComp, nop ),
( "TransformListComp", Opt_TransformListComp, nop ),
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 11d849ab71..c97d38f506 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -362,14 +362,14 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") }
@qual @varid { idtoken qvarid }
@qual @conid { idtoken qconid }
@varid { varid }
- @conid { idtoken conid }
+ @conid { conid }
}
<0> {
@qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
@qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
@varid "#"+ / { ifExtension magicHashEnabled } { varid }
- @conid "#"+ / { ifExtension magicHashEnabled } { idtoken conid }
+ @conid "#"+ / { ifExtension magicHashEnabled } { conid }
}
-- ToDo: - move `var` and (sym) into lexical syntax?
@@ -475,6 +475,9 @@ data Token
| ITgroup
| ITby
| ITusing
+ | ITnominal
+ | ITrepresentational
+ | ITphantom
-- Pragmas
| ITinline_prag InlineSpec RuleMatchInfo
@@ -669,6 +672,14 @@ reservedWordsFM = listToUFM $
( "proc", ITproc, bit arrowsBit)
]
+reservedUpcaseWordsFM :: UniqFM (Token, Int)
+reservedUpcaseWordsFM = listToUFM $
+ map (\(x, y, z) -> (mkFastString x, (y, z)))
+ [ ( "N", ITnominal, 0 ), -- no extension bit for better error msgs
+ ( "R", ITrepresentational, 0 ),
+ ( "P", ITphantom, 0 )
+ ]
+
reservedSymsFM :: UniqFM (Token, Int -> Bool)
reservedSymsFM = listToUFM $
map (\ (x,y,z) -> (mkFastString x,(y,z)))
@@ -1014,8 +1025,20 @@ varid span buf len =
where
!fs = lexemeToFastString buf len
-conid :: StringBuffer -> Int -> Token
-conid buf len = ITconid $! lexemeToFastString buf len
+conid :: Action
+conid span buf len =
+ case lookupUFM reservedUpcaseWordsFM fs of
+ Just (keyword, 0) -> return $ L span keyword
+
+ Just (keyword, exts) -> do
+ extsEnabled <- extension $ \i -> exts .&. i /= 0
+ if extsEnabled
+ then return $ L span keyword
+ else return $ L span $ ITconid fs
+
+ Nothing -> return $ L span $ ITconid fs
+ where
+ !fs = lexemeToFastString buf len
qvarsym, qconsym, prefixqvarsym, prefixqconsym :: StringBuffer -> Int -> Token
qvarsym buf len = ITqvarsym $! splitQualName buf len False
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index af297531e2..b35bbf38b4 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -59,6 +59,7 @@ import Type ( funTyCon )
import ForeignCall
import OccName ( varName, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
+import CoAxiom ( Role(..) )
import SrcLoc
import Module
import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind )
@@ -273,6 +274,9 @@ incorrect.
'group' { L _ ITgroup } -- for list transform extension
'by' { L _ ITby } -- for list transform extension
'using' { L _ ITusing } -- for list transform extension
+ 'N' { L _ ITnominal } -- Nominal role
+ 'R' { L _ ITrepresentational } -- Representational role
+ 'P' { L _ ITphantom } -- Phantom role
'{-# INLINE' { L _ (ITinline_prag _ _) }
'{-# SPECIALISE' { L _ ITspec_prag }
@@ -1129,6 +1133,7 @@ atype :: { LHsType RdrName }
| '[:' ctype ':]' { LL $ HsPArrTy $2 }
| '(' ctype ')' { LL $ HsParTy $2 }
| '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 }
+ | atype '@' role { LL $ HsRoleAnnot $1 (unLoc $3) }
| quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) }
| '$(' exp ')' { LL $ mkHsSpliceTy $2 }
| TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $
@@ -1166,8 +1171,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
| {- empty -} { [] }
tv_bndr :: { LHsTyVarBndr RdrName }
- : tyvar { L1 (UserTyVar (unLoc $1)) }
- | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4) }
+ : tyvar { L1 (HsTyVarBndr (unLoc $1) Nothing Nothing) }
+ | '(' tyvar '::' kind ')' { LL (HsTyVarBndr (unLoc $2) (Just $4) Nothing) }
fds :: { Located [Located (FunDep RdrName)] }
: {- empty -} { noLoc [] }
@@ -1185,6 +1190,11 @@ varids0 :: { Located [RdrName] }
: {- empty -} { noLoc [] }
| varids0 tyvar { LL (unLoc $2 : unLoc $1) }
+role :: { Located Role }
+ : 'N' { LL Nominal }
+ | 'R' { LL Representational }
+ | 'P' { LL Phantom }
+
-----------------------------------------------------------------------------
-- Kinds
@@ -1926,7 +1936,7 @@ qtycon :: { Located RdrName } -- Qualified or unqualified
| tycon { $1 }
tycon :: { Located RdrName } -- Unqualified
- : CONID { L1 $! mkUnqual tcClsName (getCONID $1) }
+ : upcase_id { L1 $! mkUnqual tcClsName (unLoc $1) }
qtyconsym :: { Located RdrName }
: QCONSYM { L1 $! mkQual tcClsName (getQCONSYM $1) }
@@ -2071,7 +2081,7 @@ qconid :: { Located RdrName } -- Qualified or unqualified
| PREFIXQCONSYM { L1 $! mkQual dataName (getPREFIXQCONSYM $1) }
conid :: { Located RdrName }
- : CONID { L1 $ mkUnqual dataName (getCONID $1) }
+ : upcase_id { L1 $ mkUnqual dataName (unLoc $1) }
qconsym :: { Located RdrName } -- Qualified or unqualified
: consym { $1 }
@@ -2108,7 +2118,7 @@ close :: { () }
-- Miscellaneous (mostly renamings)
modid :: { Located ModuleName }
- : CONID { L1 $ mkModuleNameFS (getCONID $1) }
+ : upcase_id { L1 $ mkModuleNameFS (unLoc $1) }
| QCONID { L1 $ let (mod,c) = getQCONID $1 in
mkModuleNameFS
(mkFastString
@@ -2119,6 +2129,12 @@ commas :: { Int } -- One or more commas
: commas ',' { $1 + 1 }
| ',' { 1 }
+upcase_id :: { Located FastString }
+ : CONID { L1 $! getCONID $1 }
+ | 'N' { L1 (fsLit "N") }
+ | 'R' { L1 (fsLit "R") }
+ | 'P' { L1 (fsLit "P") }
+
-----------------------------------------------------------------------------
-- Documentation comments
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index 0e78794515..2a4c957039 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -270,7 +270,10 @@ exp :: { IfaceExpr }
-- gaw 2004
| '%case' '(' ty ')' aexp '%of' id_bndr
'{' alts1 '}' { IfaceCase $5 (fst $7) $9 }
- | '%cast' aexp aty { IfaceCast $2 $3 }
+-- The following line is broken and is hard to fix. Not fixing now
+-- because this whole parser is bitrotten anyway.
+-- Richard Eisenberg, July 2013
+-- | '%cast' aexp aty { IfaceCast $2 $3 }
-- No InlineMe any more
-- | '%note' STRING exp
-- { case $2 of
@@ -375,7 +378,7 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName)
ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
-toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig
+toHsTvBndr (tv,k) = noLoc $ HsTyVarBndr (mkRdrUnqual (mkTyVarOccFS tv)) (Just bsig) Nothing
where
bsig = toHsKind k
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index e8c23cad52..1e61cf9f4f 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -465,10 +465,14 @@ checkTyVars tycl_hdr tparms = do { tvs <- mapM chk tparms
; return (mkHsQTvs tvs) }
where
-- Check that the name space is correct!
+ chk (L l (HsRoleAnnot (L _ (HsKindSig (L _ (HsTyVar tv)) k)) r))
+ | isRdrTyVar tv = return (L l (HsTyVarBndr tv (Just k) (Just r)))
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
- | isRdrTyVar tv = return (L l (KindedTyVar tv k))
+ | isRdrTyVar tv = return (L l (HsTyVarBndr tv (Just k) Nothing))
+ chk (L l (HsRoleAnnot (L _ (HsTyVar tv)) r))
+ | isRdrTyVar tv = return (L l (HsTyVarBndr tv Nothing (Just r)))
chk (L l (HsTyVar tv))
- | isRdrTyVar tv = return (L l (UserTyVar tv))
+ | isRdrTyVar tv = return (L l (HsTyVarBndr tv Nothing Nothing))
chk t@(L l _)
= parseErrorSDoc l $
vcat [ sep [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 2d795ab9c9..8452092ceb 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -1333,11 +1333,13 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey,
liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
- funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey :: Unique
+ funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,
+ eqReprPrimTyConKey :: Unique
statePrimTyConKey = mkPreludeTyConUnique 50
stableNamePrimTyConKey = mkPreludeTyConUnique 51
stableNameTyConKey = mkPreludeTyConUnique 52
eqPrimTyConKey = mkPreludeTyConUnique 53
+eqReprPrimTyConKey = mkPreludeTyConUnique 54
mutVarPrimTyConKey = mkPreludeTyConUnique 55
ioTyConKey = mkPreludeTyConUnique 56
wordPrimTyConKey = mkPreludeTyConUnique 58
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index b569840918..6faecaaef9 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -47,7 +47,7 @@ import BasicTypes
import DynFlags
import Platform
import Util
-import Coercion (mkUnbranchedAxInstCo,mkSymCo)
+import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..))
import Control.Monad
import Data.Bits as Bits
@@ -1020,7 +1020,7 @@ match_magicSingI (Type t : e : Lam b _ : _)
, Just (sI_tc,xs) <- splitTyConApp_maybe sI_type
, Just (_,_,co) <- unwrapNewTyCon_maybe sI_tc
= Just $ let f = setVarType b fu
- in Lam f $ Var f `App` Cast e (mkSymCo (mkUnbranchedAxInstCo co xs))
+ in Lam f $ Var f `App` Cast e (mkSymCo (mkUnbranchedAxInstCo Representational co xs))
match_magicSingI _ = Nothing
diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index a10300a99c..f166065b22 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -71,6 +71,7 @@ module TysPrim(
word64PrimTyCon, word64PrimTy,
eqPrimTyCon, -- ty1 ~# ty2
+ eqReprPrimTyCon, -- ty1 ~R# ty2 (at role Representational)
-- * Any
anyTy, anyTyCon, anyTypeOfKind,
@@ -134,6 +135,7 @@ primTyCons
, word64PrimTyCon
, anyTyCon
, eqPrimTyCon
+ , eqReprPrimTyCon
, liftedTypeKindTyCon
, unliftedTypeKindTyCon
@@ -155,7 +157,7 @@ mkPrimTc fs unique tycon
(ATyCon tycon) -- Relevant TyCon
UserSyntax -- None are built-in syntax
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, floatX4PrimTyConName, doubleX2PrimTyConName, int32X4PrimTyConName, int64X2PrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, floatX4PrimTyConName, doubleX2PrimTyConName, int32X4PrimTyConName, int64X2PrimTyConName :: Name
charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon
int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
@@ -168,6 +170,7 @@ floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatP
doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon
statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon
+eqReprPrimTyConName = mkPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon
realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
@@ -375,16 +378,16 @@ mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
\begin{code}
-- only used herein
-pcPrimTyCon :: Name -> Int -> PrimRep -> TyCon
-pcPrimTyCon name arity rep
- = mkPrimTyCon name kind arity rep
+pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon
+pcPrimTyCon name roles rep
+ = mkPrimTyCon name kind roles rep
where
- kind = mkArrowKinds (replicate arity liftedTypeKind) result_kind
+ kind = mkArrowKinds (map (const liftedTypeKind) roles) result_kind
result_kind = unliftedTypeKind
pcPrimTyCon0 :: Name -> PrimRep -> TyCon
pcPrimTyCon0 name rep
- = mkPrimTyCon name result_kind 0 rep
+ = mkPrimTyCon name result_kind [] rep
where
result_kind = unliftedTypeKind
@@ -469,19 +472,34 @@ or
where s is a type variable. The only purpose of the type parameter is to
keep different state threads separate. It is represented by nothing at all.
+The type parameter to State# is intended to keep separate threads separate.
+Even though this parameter is not used in the definition of State#, it is
+given role Nominal to enforce its intended use.
+
\begin{code}
mkStatePrimTy :: Type -> Type
mkStatePrimTy ty = TyConApp statePrimTyCon [ty]
statePrimTyCon :: TyCon -- See Note [The State# TyCon]
-statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep
+statePrimTyCon = pcPrimTyCon statePrimTyConName [Nominal] VoidRep
eqPrimTyCon :: TyCon -- The representation type for equality predicates
-- See Note [The ~# TyCon]
-eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind 3 VoidRep
+eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind [Nominal, Nominal, Nominal] VoidRep
where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind
kv = kKiVar
k = mkTyVarTy kv
+
+-- like eqPrimTyCon, but the type for *Representational* coercions
+-- this should only ever appear as the type of a covar. Its role is
+-- interpreted in coercionRole
+eqReprPrimTyCon :: TyCon
+eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName kind
+ -- the roles really should be irrelevant!
+ [Nominal, Representational, Representational] VoidRep
+ where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind
+ kv = kKiVar
+ k = mkTyVarTy kv
\end{code}
RealWorld is deeply magical. It is *primitive*, but it is not
@@ -490,7 +508,7 @@ RealWorld; it's only used in the type system, to parameterise State#.
\begin{code}
realWorldTyCon :: TyCon
-realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind 0 PtrRep
+realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind [] PtrRep
realWorldTy :: Type
realWorldTy = mkTyConTy realWorldTyCon
realWorldStatePrimTy :: Type
@@ -509,12 +527,12 @@ defined in \tr{TysWiredIn.lhs}, not here.
\begin{code}
arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon,
byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon :: TyCon
-arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName 1 PtrRep
-mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName 2 PtrRep
-mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName 1 PtrRep
-byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep
-arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName PtrRep
-mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName 1 PtrRep
+arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName [Representational] PtrRep
+mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName [Nominal, Representational] PtrRep
+mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName [Nominal] PtrRep
+byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep
+arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName PtrRep
+mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] PtrRep
mkArrayPrimTy :: Type -> Type
mkArrayPrimTy elt = TyConApp arrayPrimTyCon [elt]
@@ -538,7 +556,7 @@ mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s]
\begin{code}
mutVarPrimTyCon :: TyCon
-mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 PtrRep
+mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] PtrRep
mkMutVarPrimTy :: Type -> Type -> Type
mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt]
@@ -552,7 +570,7 @@ mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt]
\begin{code}
mVarPrimTyCon :: TyCon
-mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 PtrRep
+mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] PtrRep
mkMVarPrimTy :: Type -> Type -> Type
mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt]
@@ -566,7 +584,7 @@ mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt]
\begin{code}
tVarPrimTyCon :: TyCon
-tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName 2 PtrRep
+tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] PtrRep
mkTVarPrimTy :: Type -> Type -> Type
mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt]
@@ -580,7 +598,7 @@ mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt]
\begin{code}
stablePtrPrimTyCon :: TyCon
-stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 AddrRep
+stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName [Representational] AddrRep
mkStablePtrPrimTy :: Type -> Type
mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty]
@@ -594,7 +612,7 @@ mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty]
\begin{code}
stableNamePrimTyCon :: TyCon
-stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 PtrRep
+stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Representational] PtrRep
mkStableNamePrimTy :: Type -> Type
mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty]
@@ -621,7 +639,7 @@ bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName PtrRep
\begin{code}
weakPrimTyCon :: TyCon
-weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 PtrRep
+weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] PtrRep
mkWeakPrimTy :: Type -> Type
mkWeakPrimTy v = TyConApp weakPrimTyCon [v]
@@ -727,7 +745,7 @@ anyTy :: Type
anyTy = mkTyConTy anyTyCon
anyTyCon :: TyCon
-anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep
+anyTyCon = mkLiftedPrimTyCon anyTyConName kind [Nominal] PtrRep
where kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
{- Can't do this yet without messing up kind proxies
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index b8c0e34174..b563b25cc4 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -236,12 +236,15 @@ pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
-- Not an enumeration, not promotable
pcNonRecDataTyCon = pcTyCon False NonRecursive False
+-- This function assumes that the types it creates have all parameters at
+-- Representational role!
pcTyCon :: Bool -> RecFlag -> Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
pcTyCon is_enum is_rec is_prom name cType tyvars cons
= tycon
where
tycon = buildAlgTyCon name
tyvars
+ (map (const Representational) tyvars)
cType
[] -- No stupid theta
(DataTyCon cons is_enum)
@@ -425,6 +428,7 @@ eqTyCon :: TyCon
eqTyCon = mkAlgTyCon eqTyConName
(ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
[kv, a, b]
+ [Nominal, Nominal, Nominal]
Nothing
[] -- No stupid theta
(DataTyCon [eqBoxDataCon] False)
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index fb55ac932c..a1c4bac25c 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -213,6 +213,9 @@ rnHsTyKi isType doc (HsKindSig ty k)
; (k', fvs2) <- rnLHsKind doc k
; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
+rnHsTyKi _ doc (HsRoleAnnot ty _)
+ = illegalRoleAnnotDoc doc ty >> failM
+
rnHsTyKi isType doc (HsPArrTy ty)
= ASSERT( isType )
do { (ty', fvs) <- rnLHsType doc ty
@@ -360,7 +363,7 @@ bindHsTyVars :: HsDocContext
bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
= do { rdr_env <- getLocalRdrEnv
; let tvs = hsQTvBndrs tv_bndrs
- kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
+ kvs_from_tv_bndrs = [ kv | L _ (HsTyVarBndr _ (Just kind) _) <- tvs
, let (_, kvs) = extractHsTyRdrTyVars kind
, kv <- kvs ]
all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $
@@ -382,15 +385,19 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs
rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
- rn_tv_bndr (L loc (UserTyVar rdr))
- = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
- ; return (L loc (UserTyVar nm), emptyFVs) }
- rn_tv_bndr (L loc (KindedTyVar rdr kind))
- = do { sig_ok <- xoptM Opt_KindSignatures
- ; unless sig_ok (badSigErr False doc kind)
- ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
- ; (kind', fvs) <- rnLHsKind doc kind
- ; return (L loc (KindedTyVar nm kind'), fvs) }
+ rn_tv_bndr (L loc (HsTyVarBndr name mkind mrole))
+ = do { ksig_ok <- xoptM Opt_KindSignatures
+ ; unless ksig_ok $
+ whenIsJust mkind $ \k -> badSigErr False doc k
+ ; rsig_ok <- xoptM Opt_RoleAnnotations
+ ; unless rsig_ok $
+ whenIsJust mrole $ \_ -> badRoleAnnotOpt loc doc
+ ; nm <- newTyVarNameRn mb_assoc rdr_env loc name
+ ; (mkind', fvs) <- case mkind of
+ Just k -> do { (kind', fvs) <- rnLHsKind doc k
+ ; return (Just kind', fvs) }
+ Nothing -> return (Nothing, emptyFVs)
+ ; return (L loc (HsTyVarBndr nm mkind' mrole), fvs) }
-- Check for duplicate or shadowed tyvar bindrs
; checkDupRdrNames tv_names_w_loc
@@ -465,6 +472,19 @@ dataKindsErr is_type thing
where
what | is_type = ptext (sLit "type")
| otherwise = ptext (sLit "kind")
+
+badRoleAnnotOpt :: SrcSpan -> HsDocContext -> TcM ()
+badRoleAnnotOpt loc doc
+ = setSrcSpan loc $ addErr $
+ vcat [ ptext (sLit "Illegal role annotation")
+ , ptext (sLit "Perhaps you intended to use -XRoleAnnotations")
+ , docOfHsDocContext doc ]
+
+illegalRoleAnnotDoc :: HsDocContext -> LHsType RdrName -> TcM ()
+illegalRoleAnnotDoc doc (L loc ty)
+ = setSrcSpan loc $ addErr $
+ vcat [ ptext (sLit "Illegal role annotation on") <+> (ppr ty)
+ , docOfHsDocContext doc ]
\end{code}
Note [Renaming associated types]
@@ -1011,6 +1031,7 @@ extract_lty (L _ ty) acc
HsTyLit _ -> acc
HsWrapTy _ _ -> panic "extract_lty"
HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc)
+ HsRoleAnnot ty _ -> extract_lty ty acc
HsForAllTy _ tvs cx ty -> extract_hs_tv_bndrs tvs acc $
extract_lctxt cx $
extract_lty ty ([],[])
@@ -1027,7 +1048,7 @@ extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs })
acc_tvs ++ filterOut (`elem` local_tvs) body_tvs)
where
local_tvs = map hsLTyVarName tvs
- (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (KindedTyVar _ k) <- tvs]
+ (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (HsTyVarBndr _ (Just k) _) <- tvs]
-- These kind variables are bound here if not bound further out
extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 92874de4a3..4e40e31d9a 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -1100,7 +1100,7 @@ mkLam _env bndrs body
| not (any bad bndrs)
-- Note [Casts and lambdas]
= do { lam <- mkLam' dflags bndrs body
- ; return (mkCast lam (mkPiCos bndrs co)) }
+ ; return (mkCast lam (mkPiCos Representational bndrs co)) }
where
co_vars = tyCoVarsOfCo co
bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars
diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index c2148120e3..b88888c96c 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -724,10 +724,11 @@ match_co :: RuleMatchEnv
-> Maybe RuleSubst
match_co renv subst (CoVarCo cv) co
= match_var renv subst cv (Coercion co)
-match_co renv subst (Refl ty1) co
+match_co renv subst (Refl r1 ty1) co
= case co of
- Refl ty2 -> match_ty renv subst ty1 ty2
- _ -> Nothing
+ Refl r2 ty2
+ | r1 == r2 -> match_ty renv subst ty1 ty2
+ _ -> Nothing
match_co _ _ co1 _
= pprTrace "match_co: needs more cases" (ppr co1) Nothing
-- Currently just deals with CoVarCo and Refl
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index c1486d30c7..a5df7d52bc 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -1780,7 +1780,7 @@ argToPat env in_scope val_env (Cast arg co) arg_occ
{ -- Make a wild-card pattern for the coercion
uniq <- getUniqueUs
; let co_name = mkSysTvName uniq (fsLit "sg")
- co_var = mkCoVar co_name (mkCoercionType ty1 ty2)
+ co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2)
; return (interesting, Cast arg' (mkCoVarCo co_var)) } }
where
Pair ty1 ty2 = coercionKind co
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index 810db2069b..ca64a7fbce 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -488,7 +488,7 @@ deepSplitProductType_maybe :: Type -> Maybe (DataCon, [Type], [Type], Coercion)
-- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
-- then dc @ tys (args::arg_tys) |> co :: ty
deepSplitProductType_maybe ty
- | let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo ty)
+ | let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo Representational ty)
, Just (tc, tc_args) <- splitTyConApp_maybe ty1
, Just con <- isDataProductTyCon_maybe tc
= Just (con, tc_args, dataConInstArgTys con tc_args, co)
@@ -496,7 +496,7 @@ deepSplitProductType_maybe _ = Nothing
deepSplitCprType_maybe :: ConTag -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
deepSplitCprType_maybe con_tag ty
- | let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo ty)
+ | let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo Representational ty)
, Just (tc, tc_args) <- splitTyConApp_maybe ty1
, isDataTyCon tc
, let cons = tyConDataCons tc
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 21e2bbb5b9..ebb5b850b3 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -1444,6 +1444,7 @@ mkNewTypeEqn orig dflags tvs
&& arity_ok
&& eta_ok
&& ats_ok
+ && roles_ok
-- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes]
arity_ok = length cls_tys + 1 == classArity cls
@@ -1464,13 +1465,26 @@ mkNewTypeEqn orig dflags tvs
-- currently generate type 'instance' decls; and cannot do
-- so for 'data' instance decls
+ roles_ok = let cls_roles = tyConRoles (classTyCon cls) in
+ not (null cls_roles) && last cls_roles /= Nominal
+ -- We must make sure that the class definition (and all its
+ -- members) never pattern-match on the last parameter.
+ -- See Trac #1496 and Note [Roles] in Coercion
+
cant_derive_err
= vcat [ ppUnless arity_ok arity_msg
, ppUnless eta_ok eta_msg
- , ppUnless ats_ok ats_msg ]
+ , ppUnless ats_ok ats_msg
+ , ppUnless roles_ok roles_msg ]
arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
eta_msg = ptext (sLit "cannot eta-reduce the representation type enough")
ats_msg = ptext (sLit "the class has associated types")
+ roles_msg = ptext (sLit "it is not type-safe to use") <+>
+ ptext (sLit "GeneralizedNewtypeDeriving on this class;") $$
+ ptext (sLit "the last parameter of") <+>
+ quotes (ppr (className cls)) <+>
+ ptext (sLit "is at role N")
+
\end{code}
Note [Recursive newtypes]
diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs
index eab839a380..a18dc21438 100644
--- a/compiler/typecheck/TcEvidence.lhs
+++ b/compiler/typecheck/TcEvidence.lhs
@@ -79,6 +79,12 @@ differences
* The kind of a TcCoercion is t1 ~ t2
of a Coercion is t1 ~# t2
+ * TcCoercions are essentially all at role Nominal -- the type-checker
+ reasons only about nominal equality, not representational.
+ --> Exception: there can be newtype axioms wrapped up in TcCoercions.
+ These, of course, are only used in casts, so the desugarer
+ will still produce the right 'Coercion's.
+
* TcAxiomInstCo takes Types, not Coecions as arguments;
the generality is required only in the Simplifier
@@ -96,7 +102,7 @@ data TcCoercion
| TcAppCo TcCoercion TcCoercion
| TcForAllCo TyVar TcCoercion
| TcInstCo TcCoercion TcType
- | TcCoVarCo EqVar
+ | TcCoVarCo EqVar -- variable always at role N
| TcAxiomInstCo (CoAxiom Branched) Int [TcType] -- Int specifies branch number
-- See [CoAxiom Index] in Coercion.lhs
| TcSymCo TcCoercion
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index f65681ed1e..9914f94c5f 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -63,11 +63,30 @@ isForeignExport (L _ (ForeignExport _ _ _ _)) = True
isForeignExport _ = False
\end{code}
+Note [Don't recur in normaliseFfiType']
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+normaliseFfiType' is the workhorse for normalising a type used in a foreign
+declaration. If we have
+
+newtype Age = MkAge Int
+
+we want to see that Age -> IO () is the same as Int -> IO (). But, we don't
+need to recur on any type parameters, because no paramaterized types (with
+interesting parameters) are marshalable! The full list of marshalable types
+is in the body of boxedMarshalableTyCon in TcType. The only members of that
+list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled
+the same way regardless of type parameter. So, no need to recur into
+parameters.
+
+Similarly, we don't need to look in AppTy's, because nothing headed by
+an AppTy will be marshalable.
+
\begin{code}
-- normaliseFfiType takes the type from an FFI declaration, and
-- evaluates any type synonyms, type functions, and newtypes. However,
-- we are only allowed to look through newtypes if the constructor is
-- in scope. We return a bag of all the newtype constructors thus found.
+-- Always returns a Representational coercion
normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType ty
= do fam_envs <- tcGetFamInstEnvs
@@ -80,10 +99,11 @@ normaliseFfiType' env ty0 = go initRecTc ty0
go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms
= go rec_nts ty'
- go rec_nts (TyConApp tc tys)
+ go rec_nts ty@(TyConApp tc tys)
-- We don't want to look through the IO newtype, even if it is
-- in scope, so we have a special case for it:
| tc_key `elem` [ioTyConKey, funPtrTyConKey]
+ -- Those *must* have R roles on their parameters!
= children_only
| isNewTyCon tc -- Expand newtypes
@@ -96,44 +116,42 @@ normaliseFfiType' env ty0 = go initRecTc ty0
-- be rejected later as not being a valid FFI type.
= do { rdr_env <- getGlobalRdrEnv
; case checkNewtypeFFI rdr_env tc of
- Nothing -> children_only
+ Nothing -> nothing
Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs
; return (mkTransCo nt_co co', ty', gre `consBag` gres) } }
| isFamilyTyCon tc -- Expand open tycons
- , (co, ty) <- normaliseTcApp env tc tys
+ , (co, ty) <- normaliseTcApp env Representational tc tys
, not (isReflCo co)
= do (co', ty', gres) <- go rec_nts ty
return (mkTransCo co co', ty', gres)
| otherwise
- = children_only
+ = nothing -- see Note [Don't recur in normaliseFfiType']
where
tc_key = getUnique tc
children_only
= do xs <- mapM (go rec_nts) tys
let (cos, tys', gres) = unzip3 xs
- return (mkTyConAppCo tc cos, mkTyConApp tc tys', unionManyBags gres)
- nt_co = mkUnbranchedAxInstCo (newTyConCo tc) tys
+ return ( mkTyConAppCo Representational tc cos
+ , mkTyConApp tc tys', unionManyBags gres)
+ nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys
nt_rhs = newTyConInstRhs tc tys
-
- go rec_nts (AppTy ty1 ty2)
- = do (coi1, nty1, gres1) <- go rec_nts ty1
- (coi2, nty2, gres2) <- go rec_nts ty2
- return (mkAppCo coi1 coi2, mkAppTy nty1 nty2, gres1 `unionBags` gres2)
+ nothing = return (Refl Representational ty, ty, emptyBag)
go rec_nts (FunTy ty1 ty2)
= do (coi1,nty1,gres1) <- go rec_nts ty1
(coi2,nty2,gres2) <- go rec_nts ty2
- return (mkFunCo coi1 coi2, mkFunTy nty1 nty2, gres1 `unionBags` gres2)
+ return (mkFunCo Representational coi1 coi2, mkFunTy nty1 nty2, gres1 `unionBags` gres2)
go rec_nts (ForAllTy tyvar ty1)
= do (coi,nty1,gres1) <- go rec_nts ty1
return (mkForAllCo tyvar coi, ForAllTy tyvar nty1, gres1)
- go _ ty@(TyVarTy {}) = return (Refl ty, ty, emptyBag)
- go _ ty@(LitTy {}) = return (Refl ty, ty, emptyBag)
-
+ go _ ty@(TyVarTy {}) = return (Refl Representational ty, ty, emptyBag)
+ go _ ty@(LitTy {}) = return (Refl Representational ty, ty, emptyBag)
+ go _ ty@(AppTy {}) = return (Refl Representational ty, ty, emptyBag)
+ -- See Note [Don't recur in normaliseFfiType']
checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI rdr_env tc
diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index f4765e9425..7e2b0147ea 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -89,7 +89,7 @@ genGenericMetaTyCons tc mod =
s_occ m n = mkGenS tc_occ m n
mkTyCon name = ASSERT( isExternalName name )
- buildAlgTyCon name [] Nothing [] distinctAbstractTyConRhs
+ buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs
NonRecursive
False -- Not promotable
False -- Not GADT syntax
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index d26f371d9b..ba027b10dc 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -20,7 +20,7 @@ module TcHsType (
-- Type checking type and class decls
kcLookupKind, kcTyClTyVars, tcTyClTyVars,
tcHsConArgType, tcDataKindSig,
- tcClassSigType,
+ tcClassSigType, illegalRoleAnnot,
-- Kind-checking types
-- No kind generalisation, no checkValidType
@@ -75,6 +75,7 @@ import UniqSupply
import Outputable
import FastString
import Util
+import Maybes
import Control.Monad ( unless, when, zipWithM )
import PrelNames( ipClassName, funTyConKey )
@@ -505,6 +506,9 @@ tc_hs_type (HsKindSig ty sig_k) exp_kind
msg_fn pkind = ptext (sLit "The signature specified kind")
<+> quotes (pprKind pkind)
+tc_hs_type ty@(HsRoleAnnot {}) _
+ = pprPanic "tc_hs_type HsRoleAnnot" (ppr ty)
+
tc_hs_type (HsCoreTy ty) exp_kind
= do { checkExpectedKind ty (typeKind ty) exp_kind
; return ty }
@@ -908,21 +912,6 @@ addTypeCtxt (L _ ty) thing
%* *
%************************************************************************
-Note [Kind-checking kind-polymorphic types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider:
- f :: forall (f::k -> *) a. f a -> Int
-
-Here, the [LHsTyVarBndr Name] of the forall type will be [f,a], where
- a is a UserTyVar -> type variable without kind annotation
- f is a KindedTyVar -> type variable with kind annotation
-
-If were were to allow binding sites for kind variables, thus
- f :: forall @k (f :: k -> *) a. f a -> Int
-then we'd also need
- k is a UserKiVar -> kind variable (they don't need annotation,
- since we only have BOX for a super kind)
-
Note [Kind-checking strategies]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1120,14 +1109,15 @@ kcScopedKindVars kv_ns thing_inside
kcHsTyVarBndrs :: KindCheckingStrategy
-> LHsTyVarBndrs Name
-> TcM (Kind, r) -- the result kind, possibly with other info
- -> TcM (Kind, r)
+ -> TcM (Kind, r, [Maybe Role])
+-- See Note [Role annotations] in TcTyClsDecls about the last return value
-- Used in getInitialKind
kcHsTyVarBndrs strat (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside
= do { kvs <- if skolem_kvs
then mapM mkKindSigVar kv_ns
else mapM (\n -> newSigTyVar n superKind) kv_ns
; tcExtendTyVarEnv2 (kv_ns `zip` kvs) $
- do { nks <- mapM (kc_hs_tv . unLoc) hs_tvs
+ do { (nks, mroles) <- mapAndUnzipM (kc_hs_tv . unLoc) hs_tvs
; (res_kind, stuff) <- tcExtendKindEnv nks thing_inside
; let full_kind = mkArrowKinds (map snd nks) res_kind
kvs = filter (not . isMetaTyVar) $
@@ -1135,7 +1125,7 @@ kcHsTyVarBndrs strat (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside
gen_kind = if generalise
then mkForAllTys kvs full_kind
else full_kind
- ; return (gen_kind, stuff) } }
+ ; return (gen_kind, stuff, mroles) } }
where
-- See Note [Kind-checking strategies]
(skolem_kvs, default_to_star, generalise) = case strat of
@@ -1143,25 +1133,22 @@ kcHsTyVarBndrs strat (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside
NonParametricKinds -> (True, False, True)
FullKindSignature -> (True, True, True)
- kc_hs_tv :: HsTyVarBndr Name -> TcM (Name, TcKind)
- kc_hs_tv (UserTyVar n)
+ kc_hs_tv :: HsTyVarBndr Name -> TcM ((Name, TcKind), Maybe Role)
+ kc_hs_tv (HsTyVarBndr n mk mr)
= do { mb_thing <- tcLookupLcl_maybe n
- ; kind <- case mb_thing of
- Just (AThing k) -> return k
- _ | default_to_star -> return liftedTypeKind
- | otherwise -> newMetaKindVar
- ; return (n, kind) }
- kc_hs_tv (KindedTyVar n k)
- = do { kind <- tcLHsKind k
- -- In an associated type decl, the type variable may already
- -- be in scope; in that case we want to make sure its kind
- -- matches the one declared here
- ; mb_thing <- tcLookupLcl_maybe n
- ; case mb_thing of
- Nothing -> return ()
- Just (AThing ks) -> checkKind kind ks
- Just thing -> pprPanic "check_in_scope" (ppr thing)
- ; return (n, kind) }
+ ; kind <- case (mb_thing, mk) of
+ (Just (AThing k1), Just k2) -> do { k2' <- tcLHsKind k2
+ ; checkKind k1 k2'
+ ; return k1 }
+ (Just (AThing k), Nothing) -> return k
+ (Nothing, Just k) -> tcLHsKind k
+ (_, Nothing)
+ | default_to_star -> return liftedTypeKind
+ | otherwise -> newMetaKindVar
+ (Just thing, Just _) -> pprPanic "check_in_scope" (ppr thing)
+ ; is_boot <- tcIsHsBoot -- in boot files, roles default to R
+ ; let default_role = if is_boot then Just Representational else Nothing
+ ; return ((n, kind), firstJust mr default_role) }
tcHsTyVarBndrs :: LHsTyVarBndrs Name
-> ([TcTyVar] -> TcM r)
@@ -1186,9 +1173,8 @@ tcHsTyVarBndrs (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside
tcHsTyVarBndr :: LHsTyVarBndr Name -> TcM TcTyVar
-- Return a type variable
-- initialised with a kind variable.
--- Typically the Kind inside the KindedTyVar will be a tyvar with a mutable kind
--- in it. We aren't yet sure whether the binder is a *type* variable or a *kind*
--- variable. See Note [Kind-checking kind-polymorphic types]
+-- Typically the Kind inside the HsTyVarBndr will be a tyvar with a mutable kind
+-- in it.
--
-- If the variable is already in scope return it, instead of introducing a new
-- one. This can occur in
@@ -1196,17 +1182,20 @@ tcHsTyVarBndr :: LHsTyVarBndr Name -> TcM TcTyVar
-- type F (a,b) c = ...
-- Here a,b will be in scope when processing the associated type instance for F.
-- See Note [Associated type tyvar names] in Class
-tcHsTyVarBndr (L _ hs_tv)
- = do { let name = hsTyVarName hs_tv
- ; mb_tv <- tcLookupLcl_maybe name
+tcHsTyVarBndr (L _ (HsTyVarBndr name mkind Nothing))
+ = do { mb_tv <- tcLookupLcl_maybe name
; case mb_tv of {
Just (ATyVar _ tv) -> return tv ;
_ -> do
- { kind <- case hs_tv of
- UserTyVar {} -> newMetaKindVar
- KindedTyVar _ kind -> tcLHsKind kind
+ { kind <- case mkind of
+ Nothing -> newMetaKindVar
+ Just kind -> tcLHsKind kind
; return (mkTcTyVar name kind (SkolemTv False)) } } }
+-- tcHsTyVarBndr is never called from a context where roles annotations are allowed
+tcHsTyVarBndr (L _ (HsTyVarBndr name _ _))
+ = addErrTc (illegalRoleAnnot name) >> failM
+
------------------
kindGeneralize :: TyVarSet -> TcM [KindVar]
kindGeneralize tkvs
@@ -1291,12 +1280,11 @@ kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside
-- to match the kind variables they mention against the ones
-- we've freshly brought into scope
kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind)
- kc_tv (L _ (UserTyVar n)) exp_k
- = return (n, exp_k)
- kc_tv (L _ (KindedTyVar n hs_k)) exp_k
- = do { k <- tcLHsKind hs_k
- ; checkKind k exp_k
- ; return (n, exp_k) }
+ kc_tv (L _ (HsTyVarBndr n mkind _)) exp_k
+ | Just hs_k <- mkind = do { k <- tcLHsKind hs_k
+ ; checkKind k exp_k
+ ; return (n, exp_k) }
+ | otherwise = return (n, exp_k)
-----------------------
tcTyClTyVars :: Name -> LHsTyVarBndrs Name -- LHS of the type or class decl
@@ -1328,10 +1316,10 @@ tcTyClTyVars tycon (HsQTvs { hsq_kvs = hs_kvs, hsq_tvs = hs_tvs }) thing_inside
; tvs <- zipWithM tc_hs_tv hs_tvs kinds
; tcExtendTyVarEnv tvs (thing_inside (kvs ++ tvs) res) }
where
- tc_hs_tv (L _ (UserTyVar n)) kind = return (mkTyVar n kind)
- tc_hs_tv (L _ (KindedTyVar n hs_k)) kind = do { tc_kind <- tcLHsKind hs_k
- ; checkKind kind tc_kind
- ; return (mkTyVar n kind) }
+ tc_hs_tv (L _ (HsTyVarBndr n mkind _)) kind
+ = do { whenIsJust mkind $ \k -> do { tc_kind <- tcLHsKind k
+ ; checkKind kind tc_kind }
+ ; return $ mkTyVar n kind }
-----------------------------------
tcDataKindSig :: Kind -> TcM [TyVar]
@@ -1686,6 +1674,11 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt)
; traceTc "checkExpectedKind 1" (ppr ty $$ ppr tidy_act_kind $$ ppr tidy_exp_kind $$ ppr env1 $$ ppr env2)
; failWithTcM (env2, err) } } }
+
+illegalRoleAnnot :: Name -> SDoc
+illegalRoleAnnot var
+ = ptext (sLit "Illegal role annotation on variable") <+> ppr var <> semi $$
+ ptext (sLit "role annotations are not allowed here")
\end{code}
%************************************************************************
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 2156bba9db..79ce573d84 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -19,10 +19,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
import HsSyn
import TcBinds
-import TcTyClsDecls( tcAddImplicits, tcAddTyFamInstCtxt, tcAddDataFamInstCtxt,
- tcSynFamInstDecl,
- wrongKindOfFamily, tcFamTyPats, kcDataDefn, dataDeclChecks,
- tcConDecls, checkValidTyCon )
+import TcTyClsDecls
import TcClassDcl( tcClassDecl2,
HsSigFun, lookupHsSig, mkHsSigFun, emptyHsSigs,
findMethodBind, instantiateMethod, tcInstanceMethodBody )
@@ -65,6 +62,7 @@ import Id
import MkId
import Name
import NameSet
+import NameEnv
import Outputable
import SrcLoc
import Util
@@ -697,7 +695,8 @@ tcDataFamInstDecl mb_clsinfo
axiom = mkSingleCoAxiom axiom_name eta_tvs fam_tc eta_pats
(mkTyConApp rep_tc (mkTyVarTys eta_tvs))
parent = FamInstTyCon axiom fam_tc pats'
- rep_tc = buildAlgTyCon rep_tc_name tvs' cType stupid_theta tc_rhs
+ roles = map (const Nominal) tvs'
+ rep_tc = buildAlgTyCon rep_tc_name tvs' roles cType stupid_theta tc_rhs
Recursive
False -- No promotable to the kind level
h98_syntax parent
@@ -710,7 +709,9 @@ tcDataFamInstDecl mb_clsinfo
; return (rep_tc, fam_inst) }
-- Remember to check validity; no recursion to worry about here
- ; checkValidTyCon rep_tc
+ ; let role_annots = unitNameEnv rep_tc_name (repeat Nothing)
+ ; checkValidTyConDataConsOnly rep_tc
+ ; checkValidTyCon rep_tc role_annots
; return fam_inst } }
where
-- See Note [Eta reduction for data family axioms]
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index c0a0760f9f..23d63ba178 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -1713,7 +1713,8 @@ matchClassInst _ clas [ k, ty ] _
}
, fim_tys = tys
} | Just (_,_,axSing) <- unwrapNewTyCon_maybe tcon ->
-
+ -- co1 and co3 are at role R, while co2 is at role N.
+ -- BUT, when desugaring to Coercions, the roles get fixed.
do let co1 = mkTcSymCo $ mkTcUnbranchedAxInstCo axSing tys
co2 = mkTcSymCo $ mkTcUnbranchedAxInstCo axDataFam tys
co3 = mkTcSymCo $ mkTcUnbranchedAxInstCo axDict [k,ty]
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 56cdf60afc..d96dd22299 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -758,6 +758,7 @@ checkBootTyCon tc1 tc2
eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
in
+ roles1 == roles2 &&
-- Checks kind of class
eqListBy eqFD clas_fds1 clas_fds2 &&
(null sc_theta1 && null op_stuff1 && null ats1
@@ -777,11 +778,13 @@ checkBootTyCon tc1 tc2
= eqTypeX env t1 t2
eqSynRhs _ _ = False
in
+ roles1 == roles2 &&
eqSynRhs syn_rhs1 syn_rhs2
| isAlgTyCon tc1 && isAlgTyCon tc2
, Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
= ASSERT(tc1 == tc2)
+ roles1 == roles2 &&
eqListBy (eqPredX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
@@ -791,6 +794,9 @@ checkBootTyCon tc1 tc2
| otherwise = False
where
+ roles1 = tyConRoles tc1
+ roles2 = tyConRoles tc2
+
eqAlgRhs (AbstractTyCon dis1) rhs2
| dis1 = isDistinctAlgRhs rhs2 --Check compatibility
| otherwise = True
@@ -1499,7 +1505,7 @@ getGhciStepIO = do
stepTy :: LHsType Name -- Renamed, so needs all binders in place
stepTy = noLoc $ HsForAllTy Implicit
- (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)]
+ (HsQTvs { hsq_tvs = [noLoc (HsTyVarBndr a_tv Nothing Nothing)]
, hsq_kvs = [] })
(noLoc [])
(nlHsFunTy ghciM ioM)
@@ -1590,9 +1596,9 @@ tcRnType hsc_env ictxt normalise rdr_type
; ty' <- if normalise
then do { fam_envs <- tcGetFamInstEnvs
- ; return (snd (normaliseType fam_envs ty)) }
+ ; return (snd (normaliseType fam_envs Nominal ty)) }
-- normaliseType returns a coercion
- -- which we discard
+ -- which we discard, so the Role is irrelevant
else return ty ;
; return (ty', typeKind ty) }
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 59b06d4a8e..bb24708882 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -76,7 +76,7 @@ import BasicTypes
import DynFlags
import Panic
import FastString
-import Control.Monad ( when )
+import Control.Monad ( when, zipWithM )
import qualified Language.Haskell.TH as TH
-- THSyntax gives access to internal functions and data types
@@ -1215,7 +1215,7 @@ reifyTyCon tc
; kind' <- if isLiftedTypeKind kind then return Nothing
else fmap Just (reifyKind kind)
- ; tvs' <- reifyTyVars tvs
+ ; tvs' <- reifyTyVars tvs Nothing
; flav' <- reifyFamFlavour tc
; case flav' of
{ Left flav -> -- open type/data family
@@ -1231,7 +1231,7 @@ reifyTyCon tc
| Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym
= do { rhs' <- reifyType rhs
- ; tvs' <- reifyTyVars tvs
+ ; tvs' <- reifyTyVars tvs (Just $ tyConRoles tc)
; return (TH.TyConI
(TH.TySynD (reifyName tc) tvs' rhs'))
}
@@ -1240,7 +1240,7 @@ reifyTyCon tc
= do { cxt <- reifyCxt (tyConStupidTheta tc)
; let tvs = tyConTyVars tc
; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
- ; r_tvs <- reifyTyVars tvs
+ ; r_tvs <- reifyTyVars tvs (Just $ tyConRoles tc)
; let name = reifyName tc
deriv = [] -- Don't know about deriving
decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
@@ -1276,7 +1276,7 @@ reifyDataCon tys dc
return main_con
else do
{ cxt <- reifyCxt theta'
- ; ex_tvs'' <- reifyTyVars ex_tvs'
+ ; ex_tvs'' <- reifyTyVars ex_tvs' Nothing
; return (TH.ForallC ex_tvs'' cxt main_con) } }
------------------------------
@@ -1286,7 +1286,7 @@ reifyClass cls
; inst_envs <- tcGetInstEnvs
; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls)
; ops <- mapM reify_op op_stuff
- ; tvs' <- reifyTyVars tvs
+ ; tvs' <- reifyTyVars tvs (Just $ tyConRoles (classTyCon cls))
; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops
; return (TH.ClassI dec insts ) }
where
@@ -1344,7 +1344,7 @@ reify_for_all :: TypeRep.Type -> TcM TH.Type
reify_for_all ty
= do { cxt' <- reifyCxt cxt;
; tau' <- reifyType tau
- ; tvs' <- reifyTyVars tvs
+ ; tvs' <- reifyTyVars tvs Nothing
; return (TH.ForallT tvs' cxt' tau') }
where
(tvs, cxt, tau) = tcSplitSigmaTy ty
@@ -1401,16 +1401,34 @@ reifyFamFlavour tc
| otherwise
= panic "TcSplice.reifyFamFlavour: not a type family"
-reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr]
-reifyTyVars = mapM reifyTyVar . filter isTypeVar
+reifyTyVars :: [TyVar] -> Maybe [Role] -- use Nothing if role annot.s are not allowed
+ -> TcM [TH.TyVarBndr]
+reifyTyVars tvs Nothing = mapM reify_tv $ filter isTypeVar tvs
where
- reifyTyVar tv | isLiftedTypeKind kind = return (TH.PlainTV name)
- | otherwise = do kind' <- reifyKind kind
- return (TH.KindedTV name kind')
+ reify_tv tv | isLiftedTypeKind kind = return (TH.PlainTV name)
+ | otherwise = do kind' <- reifyKind kind
+ return (TH.KindedTV name kind')
where
kind = tyVarKind tv
name = reifyName tv
+reifyTyVars tvs (Just roles) = zipWithM reify_tv tvs' roles'
+ where
+ (kvs, tvs') = span isKindVar tvs
+ roles' = dropList kvs roles
+
+ reify_tv tv role
+ | isLiftedTypeKind kind = return (TH.RoledTV name role')
+ | otherwise = do kind' <- reifyKind kind
+ return (TH.KindedRoledTV name kind' role')
+ where
+ kind = tyVarKind tv
+ name = reifyName tv
+ role' = case role of
+ CoAxiom.Nominal -> TH.Nominal
+ CoAxiom.Representational -> TH.Representational
+ CoAxiom.Phantom -> TH.Phantom
+
reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type
reify_tc_app tc tys
= do { tys' <- reifyTypes (removeKinds (tyConKind tc) tys)
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 4d7f70dc93..147927300b 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -14,6 +14,7 @@ module TcTyClsDecls (
-- Functions used by TcInstDcls to check
-- data/type family instance declarations
kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon,
+ checkValidTyConDataConsOnly,
tcSynFamInstDecl, tcFamTyPats,
tcAddTyFamInstCtxt, tcAddDataFamInstCtxt,
wrongKindOfFamily,
@@ -38,8 +39,9 @@ import TcType
import TysWiredIn( unitTy )
import FamInst
import FamInstEnv( isDominatedBy, mkCoAxBranch, mkBranchedCoAxiom )
-import Coercion( pprCoAxBranch )
+import Coercion( pprCoAxBranch, ltRole )
import Type
+import TypeRep -- for checkValidRoles
import Kind
import Class
import CoAxiom
@@ -122,13 +124,14 @@ tcTyClGroup boot_details 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
+ -- See also Note [Role annotations]
+ (names_w_poly_kinds, role_annots) <- kcTyClGroup tyclds
; traceTc "tcTyAndCl generalized kinds" (ppr names_w_poly_kinds)
-- Step 2: type-check all groups together, returning
-- the final TyCons and Classes
; tyclss <- fixM $ \ rec_tyclss -> do
- { let rec_flags = calcRecFlags boot_details rec_tyclss
+ { let rec_flags = calcRecFlags boot_details role_annots rec_tyclss
-- Populate environment with knot-tied ATyCon for TyCons
-- NB: if the decls mention any ill-staged data cons
@@ -150,11 +153,19 @@ tcTyClGroup boot_details tyclds
-- expects well-formed TyCons
; tcExtendGlobalEnv tyclss $ do
{ traceTc "Starting validity check" (ppr tyclss)
- ; checkNoErrs $
- mapM_ (recoverM (return ()) . addLocM checkValidTyCl) tyclds
+ ; -- Step 3a: Check datacons only. Why? Because checking tycons in general
+ -- also checks for role consistency, which looks at types. But, a mal-formed
+ -- GADT return type means that a datacon has a panic in its types
+ -- (see rejigConRes). So, we check all datacons first, before doing other
+ -- checks.
+ checkNoErrs $
+ mapM_ (recoverM (return ()) . addLocM checkValidTyClDataConsOnly) tyclds
+ -- The checkNoErrs above fixes Trac #7175
+
+ -- Step 3b: do the rest of validity checking
+ ; mapM_ (recoverM (return ()) . addLocM (checkValidTyCl role_annots)) tyclds
-- We recover, which allows us to report multiple validity errors
- -- but we then fail if any are wrong. Lacking the checkNoErrs
- -- we get Trac #7175
+ -- but we then fail if any are wrong.
-- Step 4: Add the implicit things;
-- we want them in the environment because
@@ -248,11 +259,29 @@ instances of families altogether in the following. However, we need to include
the kinds of *associated* families into the construction of the initial kind
environment. (This is handled by `allDecls').
+Note [Role annotations]
+~~~~~~~~~~~~~~~~~~~~~~~
+Role processing is threaded through the kind- and type-checker. Here is the
+route:
+
+1. kcTyClGroup returns a list of (Name, Kind, [Maybe Role]) triples. The
+elements of the role list correspond to type variables associated with the Name.
+Nothing indicates no role annotation. Just r indicates an annotation r.
+
+2. The role annotations are passed into calcRecFlags, which among other things,
+performs role inference. The role annotations are used to initialize the role
+inference algorithm.
+
+3. During validity-checking (in checkRoleAnnot), the inferred roles are
+then checked against the annotations. If they don't match, an error is reported.
+This is also where the presence of the RoleAnnotations flag is checked.
+
\begin{code}
-kcTyClGroup :: TyClGroup Name -> TcM [(Name,Kind)]
+kcTyClGroup :: TyClGroup Name -> TcM ([(Name,Kind)], RoleAnnots)
-- 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]
+-- Role annotation extraction is done here, too. See Note [Role annotations]
kcTyClGroup decls
= do { mod <- getModule
; traceTc "kcTyClGroup" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls))
@@ -266,12 +295,13 @@ kcTyClGroup decls
-- Step 1: Bind kind variables for non-synonyms
; let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls
- ; initial_kinds <- getInitialKinds non_syn_decls
+ ; (initial_kinds, role_env) <- getInitialKinds non_syn_decls
; traceTc "kcTyClGroup: initial kinds" (ppr initial_kinds)
-- Step 2: Set initial envt, kind-check the synonyms
- ; lcl_env <- tcExtendTcTyThingEnv initial_kinds $
- kcSynDecls (calcSynCycles syn_decls)
+ -- See Note [Role annotations]
+ ; (lcl_env, role_env') <- tcExtendTcTyThingEnv initial_kinds $
+ kcSynDecls (calcSynCycles syn_decls)
-- Step 3: Set extended envt, kind-check the non-synonyms
; setLclEnv lcl_env $
@@ -283,7 +313,7 @@ kcTyClGroup decls
; res <- concatMapM (generaliseTCD (tcl_env lcl_env)) decls
; traceTc "kcTyClGroup result" (ppr res)
- ; return res }
+ ; return (res, role_env `plusNameEnv` role_env') }
where
generalise :: TcTypeEnv -> Name -> TcM (Name, Kind)
@@ -332,13 +362,14 @@ mk_thing_env (decl : decls)
= (tcdName (unLoc decl), APromotionErr TyConPE) :
(mk_thing_env decls)
-getInitialKinds :: [LTyClDecl Name] -> TcM [(Name, TcTyThing)]
+getInitialKinds :: [LTyClDecl Name] -> TcM ([(Name, TcTyThing)], RoleAnnots)
getInitialKinds decls
= tcExtendTcTyThingEnv (mk_thing_env decls) $
- concatMapM (addLocM getInitialKind) decls
+ do { (pairss, annots) <- mapAndUnzipM (addLocM getInitialKind) decls
+ ; return (concat pairss, mkNameEnv (zip (map (tcdName . unLoc) decls) annots)) }
-- See Note [Kind-checking strategies] in TcHsType
-getInitialKind :: TyClDecl Name -> TcM [(Name, TcTyThing)]
+getInitialKind :: TyClDecl Name -> TcM ([(Name, TcTyThing)], [Maybe Role])
-- Allocate a fresh kind variable for each TyCon and Class
-- For each tycon, return (tc, AThing k)
-- where k is the kind of tc, derived from the LHS
@@ -357,33 +388,37 @@ getInitialKind :: TyClDecl Name -> TcM [(Name, TcTyThing)]
-- No family instances are passed to getInitialKinds
getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats })
- = do { (cl_kind, inner_prs) <-
+ = do { (cl_kind, inner_prs, role_annots) <-
kcHsTyVarBndrs (kcStrategy decl) ktvs $
do { inner_prs <- getFamDeclInitialKinds ats
; return (constraintKind, inner_prs) }
; let main_pr = (name, AThing cl_kind)
- ; return (main_pr : inner_prs) }
+ ; return ((main_pr : inner_prs), role_annots) }
getInitialKind decl@(DataDecl { tcdLName = L _ name
, tcdTyVars = ktvs
, tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
, dd_cons = cons } })
- = do { (decl_kind, _) <-
+ = do { (decl_kind, num_extra_tvs, role_annots) <-
kcHsTyVarBndrs (kcStrategy decl) ktvs $
do { res_k <- case m_sig of
Just ksig -> tcLHsKind ksig
Nothing -> return liftedTypeKind
- ; return (res_k, ()) }
+ -- return the number of extra type arguments from the res_k so
+ -- we can extend the role_annots list
+ ; return (res_k, length $ fst $ splitKindFunTys res_k) }
; let main_pr = (name, AThing decl_kind)
inner_prs = [ (unLoc (con_name con), APromotionErr RecDataConPE)
| L _ con <- cons ]
- ; return (main_pr : inner_prs) }
+ role_annots' = role_annots ++ replicate num_extra_tvs Nothing
+ ; return ((main_pr : inner_prs), role_annots') }
getInitialKind (FamDecl { tcdFam = decl })
- = getFamDeclInitialKind decl
+ = do { pairs <- getFamDeclInitialKind decl
+ ; return (pairs, []) }
getInitialKind (ForeignType { tcdLName = L _ name })
- = return [(name, AThing liftedTypeKind)]
+ = return ([(name, AThing liftedTypeKind)], [])
getInitialKind decl@(SynDecl {})
= pprPanic "getInitialKind" (ppr decl)
@@ -401,7 +436,7 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name
, fdInfo = info
, fdTyVars = ktvs
, fdKindSig = ksig })
- = do { (fam_kind, _) <-
+ = do { (fam_kind, _, _) <-
kcHsTyVarBndrs (kcStrategyFamDecl decl) ktvs $
do { res_k <- case ksig of
Just k -> tcLHsKind k
@@ -414,31 +449,34 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name
defaultResToStar = not $ isClosedTypeFamilyInfo info
----------------
-kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM TcLclEnv -- Kind bindings
-kcSynDecls [] = getLclEnv
+kcSynDecls :: [SCC (LTyClDecl Name)]
+ -> TcM (TcLclEnv, RoleAnnots) -- Kind bindings and roles
+kcSynDecls [] = do { env <- getLclEnv
+ ; return (env, emptyNameEnv) }
kcSynDecls (group : groups)
- = do { nk <- kcSynDecl1 group
- ; tcExtendKindEnv [nk] (kcSynDecls groups) }
+ = do { (n,k,mr) <- kcSynDecl1 group
+ ; (lcl_env, role_env) <- tcExtendKindEnv [(n,k)] (kcSynDecls groups)
+ ; return (lcl_env, extendNameEnv role_env n mr) }
kcSynDecl1 :: SCC (LTyClDecl Name)
- -> TcM (Name,TcKind) -- Kind bindings
+ -> TcM (Name,TcKind,[Maybe Role]) -- Kind bindings with roles
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)
+kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind, [Maybe Role])
kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name
, tcdRhs = rhs })
-- Returns a possibly-unzonked kind
= tcAddDeclCtxt decl $
- do { (syn_kind, _) <-
+ do { (syn_kind, _, mroles) <-
kcHsTyVarBndrs (kcStrategy 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) }
+ ; return (name, syn_kind, mroles) }
kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl)
------------------------------------------------------------------------
@@ -449,6 +487,7 @@ kcLTyClDecl (L loc decl)
kcTyClDecl :: TyClDecl Name -> TcM ()
-- This function is used solely for its side effect on kind variables
+-- and to extract role annotations
-- NB kind signatures on the type variables and
-- result kind signature have aready been dealt with
-- by getInitialKind, so we can ignore them here.
@@ -579,11 +618,11 @@ tcTyClDecl1 parent _rec_info (FamDecl { tcdFam = fd })
= tcFamDecl1 parent fd
-- "type" synonym declaration
-tcTyClDecl1 _parent _rec_info
+tcTyClDecl1 _parent rec_info
(SynDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdRhs = rhs })
= ASSERT( isNoParent _parent )
tcTyClTyVars tc_name tvs $ \ tvs' kind ->
- tcTySynRhs tc_name tvs' kind rhs
+ tcTySynRhs rec_info tc_name tvs' kind rhs
-- "data/newtype" declaration
tcTyClDecl1 _parent rec_info
@@ -601,11 +640,12 @@ tcTyClDecl1 _parent rec_info
do { (clas, tvs', gen_dm_env) <- fixM $ \ ~(clas,_,_) ->
tcTyClTyVars class_name tvs $ \ tvs' kind ->
do { MASSERT( isConstraintKind kind )
- ; let -- 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
- tycon_name = tyConName (classTyCon clas)
- tc_isrec = rti_is_rec rec_info tycon_name
+ -- 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
+ ; let tycon_name = tyConName (classTyCon clas)
+ tc_isrec = rti_is_rec rec_info tycon_name
+ roles = rti_roles rec_info tycon_name
; ctxt' <- tcHsContext ctxt
; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt'
@@ -614,7 +654,7 @@ tcTyClDecl1 _parent rec_info
; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs
; clas <- buildClass False {- Must include unfoldings for selectors -}
- class_name tvs' ctxt' fds' at_stuff
+ class_name tvs' roles ctxt' fds' at_stuff
sig_stuff tc_isrec
; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds')
; return (clas, tvs', gen_dm_env) }
@@ -647,7 +687,7 @@ tcTyClDecl1 _parent rec_info
tcTyClDecl1 _ _
(ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
- = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
+ = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind)]
\end{code}
\begin{code}
@@ -657,7 +697,9 @@ tcFamDecl1 parent
= tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
{ traceTc "open type family:" (ppr tc_name)
; checkFamFlag tc_name
- ; tycon <- buildSynTyCon tc_name tvs' OpenSynFamilyTyCon kind parent
+ ; checkNoRoles tvs
+ ; let roles = map (const Nominal) tvs'
+ ; tycon <- buildSynTyCon tc_name tvs' roles OpenSynFamilyTyCon kind parent
; return [ATyCon tycon] }
tcFamDecl1 parent
@@ -671,6 +713,7 @@ tcFamDecl1 parent
return (tvs', kind)
; checkFamFlag tc_name -- make sure we have -XTypeFamilies
+ ; checkNoRoles tvs
-- check to make sure all the names used in the equations are
-- consistent
@@ -698,7 +741,8 @@ tcFamDecl1 parent
-- now, finally, build the TyCon
; let syn_rhs = ClosedSynFamilyTyCon co_ax
- ; tycon <- buildSynTyCon tc_name tvs' syn_rhs kind parent
+ roles = map (const Nominal) tvs'
+ ; tycon <- buildSynTyCon tc_name tvs' roles syn_rhs kind parent
; return [ATyCon tycon, ACoAxiom co_ax] }
-- We check for instance validity later, when doing validity checking for
@@ -709,24 +753,28 @@ tcFamDecl1 parent
= tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
{ traceTc "data family:" (ppr tc_name)
; checkFamFlag tc_name
+ ; checkNoRoles tvs
; extra_tvs <- tcDataKindSig kind
; let final_tvs = tvs' ++ extra_tvs -- we may not need these
- tycon = buildAlgTyCon tc_name final_tvs Nothing []
+ roles = map (const Nominal) final_tvs
+ tycon = buildAlgTyCon tc_name final_tvs roles Nothing []
DataFamilyTyCon Recursive
False -- Not promotable to the kind level
True -- GADT syntax
parent
; return [ATyCon tycon] }
-tcTySynRhs :: Name
+tcTySynRhs :: RecTyInfo
+ -> Name
-> [TyVar] -> Kind
-> LHsType Name -> TcM [TyThing]
-tcTySynRhs tc_name tvs kind hs_ty
+tcTySynRhs rec_info tc_name tvs kind hs_ty
= do { env <- getLclEnv
; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))
; rhs_ty <- tcCheckLHsType hs_ty kind
; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
- ; tycon <- buildSynTyCon tc_name tvs (SynonymTyCon rhs_ty)
+ ; let roles = rti_roles rec_info tc_name
+ ; tycon <- buildSynTyCon tc_name tvs roles (SynonymTyCon rhs_ty)
kind NoParentTyCon
; return [ATyCon tycon] }
@@ -740,6 +788,7 @@ tcDataDefn rec_info tc_name tvs kind
, dd_cons = cons })
= do { extra_tvs <- tcDataKindSig kind
; let final_tvs = tvs ++ extra_tvs
+ roles = rti_roles rec_info tc_name
; stupid_theta <- tcHsContext ctxt
; kind_signatures <- xoptM Opt_KindSignatures
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
@@ -764,7 +813,7 @@ tcDataDefn rec_info tc_name tvs kind
DataType -> return (mkDataTyConRhs data_cons)
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs tc_name tycon (head data_cons)
- ; return (buildAlgTyCon tc_name final_tvs cType stupid_theta tc_rhs
+ ; return (buildAlgTyCon tc_name final_tvs roles cType stupid_theta tc_rhs
(rti_is_rec rec_info tc_name)
(rti_promotable rec_info)
(not h98_syntax) NoParentTyCon) }
@@ -1269,8 +1318,8 @@ checkClassCycleErrs cls
where cls_cycles = calcClassCycles cls
checkValidDecl :: SDoc -- the context for error checking
- -> Located Name -> TcM ()
-checkValidDecl ctxt lname
+ -> Located Name -> RoleAnnots -> TcM ()
+checkValidDecl ctxt lname mroles
= addErrCtxt ctxt $
do { traceTc "Validity of 1" (ppr lname)
; env <- getGblEnv
@@ -1281,16 +1330,38 @@ checkValidDecl ctxt lname
; case thing of
ATyCon tc -> do
traceTc " of kind" (ppr (tyConKind tc))
- checkValidTyCon tc
+ checkValidTyCon tc mroles
AnId _ -> return () -- Generic default methods are checked
-- with their parent class
_ -> panic "checkValidTyCl"
; traceTc "Done validity of" (ppr thing)
}
-checkValidTyCl :: TyClDecl Name -> TcM ()
-checkValidTyCl decl
- = do { checkValidDecl (tcMkDeclCtxt decl) (tyClDeclLName decl)
+checkValidTyClDataConsOnly :: TyClDecl Name -> TcM ()
+checkValidTyClDataConsOnly decl
+ | DataDecl {} <- decl = check_datacons_decl
+ | otherwise = return ()
+ where
+ lname = tyClDeclLName decl
+ check_datacons_decl
+ = addErrCtxt (tcMkDeclCtxt decl) $
+ do { thing <- tcLookupLocatedGlobal lname
+ ; case thing of
+ ATyCon tc -> checkValidTyConDataConsOnly tc
+ _ -> pprPanic "checkValidTyClDataConsOnly" (ppr lname) }
+
+checkValidTyConDataConsOnly :: TyCon -> TcM ()
+checkValidTyConDataConsOnly tc
+ = do { -- Check arg types of data constructors
+ dflags <- getDynFlags
+ ; existential_ok <- xoptM Opt_ExistentialQuantification
+ ; gadt_ok <- xoptM Opt_GADTs
+ ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
+ ; mapM_ (checkValidDataCon dflags ex_ok tc) (tyConDataCons tc) }
+
+checkValidTyCl :: RoleAnnots -> TyClDecl Name -> TcM ()
+checkValidTyCl mroles decl
+ = do { checkValidDecl (tcMkDeclCtxt decl) (tyClDeclLName decl) mroles
; case decl of
ClassDecl { tcdATs = ats } ->
mapM_ (checkValidFamDecl . unLoc) ats
@@ -1301,6 +1372,7 @@ checkValidFamDecl (FamilyDecl { fdLName = lname, fdInfo = flav })
= checkValidDecl (hsep [ptext (sLit "In the"), ppr flav,
ptext (sLit "declaration for"), quotes (ppr lname)])
lname
+ (pprPanic "checkValidFamDecl" (ppr lname)) -- no roles on families
-------------------------
-- For data types declared with record syntax, we require
@@ -1317,31 +1389,29 @@ checkValidFamDecl (FamilyDecl { fdLName = lname, fdInfo = flav })
-- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T
-- Here we do not complain about f1,f2 because they are existential
-checkValidTyCon :: TyCon -> TcM ()
-checkValidTyCon tc
+checkValidTyCon :: TyCon -> RoleAnnots -> TcM ()
+checkValidTyCon tc mroles
| Just cl <- tyConClass_maybe tc
- = checkValidClass cl
+ = do { check_roles
+ ; checkValidClass cl }
| Just syn_rhs <- synTyConRhs_maybe tc
= case syn_rhs of
ClosedSynFamilyTyCon ax -> checkValidClosedCoAxiom ax
OpenSynFamilyTyCon -> return ()
- SynonymTyCon ty -> checkValidType syn_ctxt ty
+ SynonymTyCon ty ->
+ do { check_roles
+ ; checkValidType syn_ctxt ty }
| otherwise
- = do { -- Check the context on the data decl
+ = do { unless (isFamilyTyCon tc) $ check_roles -- don't check data families!
+
+-- Check the context on the data decl
; traceTc "cvtc1" (ppr tc)
; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
- -- Check arg types of data constructors
; traceTc "cvtc2" (ppr tc)
- ; dflags <- getDynFlags
- ; existential_ok <- xoptM Opt_ExistentialQuantification
- ; gadt_ok <- xoptM Opt_GADTs
- ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
- ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons
-
-- Check that fields with the same name share a type
; mapM_ check_fields groups }
@@ -1350,6 +1420,23 @@ checkValidTyCon tc
name = tyConName tc
data_cons = tyConDataCons tc
+ -- Role annotations are given only on *type* variables, but a tycon stores
+ -- roles for all variables. So, we drop the kind roles (which are all
+ -- Nominal, anyway).
+ tyvars = tyConTyVars tc
+ (kind_vars, type_vars) = span isKindVar tyvars
+ roles = tyConRoles tc
+ type_roles = dropList kind_vars roles
+
+ role_annots = case lookupNameEnv mroles name of
+ Just rs -> rs
+ Nothing -> pprPanic "checkValidTyCon role_annots" (ppr name)
+
+ check_roles
+ = do { _ <- zipWith3M checkRoleAnnot type_vars role_annots type_roles
+ ; lint <- goptM Opt_DoCoreLinting
+ ; when lint $ checkValidRoles tc }
+
groups = equivClasses cmp_fld (concatMap get_fields data_cons)
cmp_fld (f1,_) (f2,_) = f1 `compare` f2
get_fields con = dataConFieldLabels con `zip` repeat con
@@ -1390,6 +1477,77 @@ checkValidTyCon tc
fty2 = dataConFieldType con2 label
check_fields [] = panic "checkValidTyCon/check_fields []"
+checkRoleAnnot :: TyVar -> Maybe Role -> Role -> TcM ()
+checkRoleAnnot _ Nothing _ = return ()
+checkRoleAnnot tv (Just r1) r2
+ = when (r1 /= r2) $
+ addErrTc $ badRoleAnnot (tyVarName tv) r1 r2
+
+-- This is a double-check on the role inference algorithm. It is only run when
+-- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls
+checkValidRoles :: TyCon -> TcM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism] in CoreLint
+checkValidRoles tc
+ | isAlgTyCon tc
+ -- tyConDataCons returns an empty list for data families
+ = mapM_ check_dc_roles (tyConDataCons tc)
+ | Just (SynonymTyCon rhs) <- synTyConRhs_maybe tc
+ = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs
+ | otherwise
+ = return ()
+ where
+ check_dc_roles datacon
+ = let univ_tvs = dataConUnivTyVars datacon
+ ex_tvs = dataConExTyVars datacon
+ args = dataConRepArgTys datacon
+ univ_roles = zipVarEnv univ_tvs (tyConRoles tc)
+ -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs
+ ex_roles = mkVarEnv (zip ex_tvs (repeat Nominal))
+ role_env = univ_roles `plusVarEnv` ex_roles in
+ mapM_ (check_ty_roles role_env Representational) args
+
+ check_ty_roles env role (TyVarTy tv)
+ = case lookupVarEnv env tv of
+ Just role' -> unless (role' `ltRole` role || role' == role) $
+ report_error $ ptext (sLit "type variable") <+> quotes (ppr tv) <+>
+ ptext (sLit "cannot have role") <+> ppr role <+>
+ ptext (sLit "because it was assigned role") <+> ppr role'
+ Nothing -> report_error $ ptext (sLit "type variable") <+> quotes (ppr tv) <+>
+ ptext (sLit "missing in environment")
+
+ check_ty_roles env Representational (TyConApp tc tys)
+ = let roles' = tyConRoles tc in
+ zipWithM_ (maybe_check_ty_roles env) roles' tys
+
+ check_ty_roles env Nominal (TyConApp _ tys)
+ = mapM_ (check_ty_roles env Nominal) tys
+
+ check_ty_roles _ Phantom ty@(TyConApp {})
+ = pprPanic "check_ty_roles" (ppr ty)
+
+ check_ty_roles env role (AppTy ty1 ty2)
+ = check_ty_roles env role ty1
+ >> check_ty_roles env Nominal ty2
+
+ check_ty_roles env role (FunTy ty1 ty2)
+ = check_ty_roles env role ty1
+ >> check_ty_roles env role ty2
+
+ check_ty_roles env role (ForAllTy tv ty)
+ = check_ty_roles (extendVarEnv env tv Nominal) role ty
+
+ check_ty_roles _ _ (LitTy {}) = return ()
+
+ maybe_check_ty_roles env role ty
+ = when (role == Nominal || role == Representational) $
+ check_ty_roles env role ty
+
+ report_error doc
+ = addErrTc $ vcat [ptext (sLit "Internal error in role inference:"),
+ doc,
+ ptext (sLit "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug")]
+
checkValidClosedCoAxiom :: CoAxiom Branched -> TcM ()
checkValidClosedCoAxiom (CoAxiom { co_ax_branches = branches, co_ax_tc = tc })
= tcAddClosedTypeFamilyDeclCtxt tc $
@@ -1579,6 +1737,13 @@ checkFamFlag tc_name
where
err_msg = hang (ptext (sLit "Illegal family declaraion for") <+> quotes (ppr tc_name))
2 (ptext (sLit "Use -XTypeFamilies to allow indexed type families"))
+
+checkNoRoles :: LHsTyVarBndrs Name -> TcM ()
+checkNoRoles (HsQTvs { hsq_tvs = tvs })
+ = mapM_ check tvs
+ where
+ check (L _ (HsTyVarBndr _ _ Nothing)) = return ()
+ check (L _ (HsTyVarBndr name _ (Just _))) = addErrTc $ illegalRoleAnnot name
\end{code}
@@ -1960,4 +2125,11 @@ inaccessibleCoAxBranch tc fi
= ptext (sLit "Inaccessible family instance equation:") $$
(pprCoAxBranch tc fi)
+badRoleAnnot :: Name -> Role -> Role -> SDoc
+badRoleAnnot var annot inferred
+ = hang (ptext (sLit "Role mismatch on variable") <+> ppr var <> colon)
+ 2 (sep [ ptext (sLit "Annotation says"), ppr annot
+ , ptext (sLit "but role"), ppr inferred
+ , ptext (sLit "is required") ])
+
\end{code}
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index fb54899715..bea2cd19be 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -18,7 +18,8 @@ files for imported data types.
module TcTyDecls(
calcRecFlags, RecTyInfo(..),
- calcSynCycles, calcClassCycles
+ calcSynCycles, calcClassCycles,
+ RoleAnnots
) where
#include "HsVersions.h"
@@ -34,15 +35,20 @@ import DataCon
import Var
import Name
import NameEnv
+import VarEnv
+import VarSet
import NameSet
+import Coercion ( ltRole )
import Avail
import Digraph
import BasicTypes
import SrcLoc
+import Outputable
import UniqSet
-import Maybes( mapCatMaybes, isJust )
-import Util ( lengthIs, isSingleton )
+import Util
+import Maybes
import Data.List
+import Control.Monad
\end{code}
@@ -351,13 +357,15 @@ compiled, plus the outer structure of directly-mentioned types.
\begin{code}
data RecTyInfo = RTI { rti_promotable :: Bool
+ , rti_roles :: Name -> [Role]
, rti_is_rec :: Name -> RecFlag }
-calcRecFlags :: ModDetails -> [TyThing] -> RecTyInfo
+calcRecFlags :: ModDetails -> RoleAnnots -> [TyThing] -> RecTyInfo
-- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
-- Any type constructors in boot_names are automatically considered loop breakers
-calcRecFlags boot_details tyclss
+calcRecFlags boot_details mrole_env tyclss
= RTI { rti_promotable = is_promotable
+ , rti_roles = roles
, rti_is_rec = is_rec }
where
rec_tycon_names = mkNameSet (map tyConName all_tycons)
@@ -367,6 +375,8 @@ calcRecFlags boot_details tyclss
is_promotable = all (isPromotableTyCon rec_tycon_names) all_tycons
+ roles = inferRoles mrole_env all_tycons
+
----------------- Recursion calculation ----------------
is_rec n | n `elemNameSet` rec_names = Recursive
| otherwise = NonRecursive
@@ -518,6 +528,279 @@ isPromotableType rec_tcs con_arg_ty
go _ = False
\end{code}
+%************************************************************************
+%* *
+ Role inference
+%* *
+%************************************************************************
+
+Note [Role inference]
+~~~~~~~~~~~~~~~~~~~~~
+The role inference algorithm uses class, datatype, and synonym definitions
+to infer the roles on the parameters. Although these roles are stored in the
+tycons, we can perform this algorithm on the built tycons, as long as we
+don't peek at an as-yet-unknown roles field! Ah, the magic of laziness.
+
+First, we choose appropriate initial roles. For families, roles (including
+initial roles) are N. For all other types, we start with the role in the
+role annotation (if any), or otherwise use Phantom. This is done in
+initialRoleEnv1.
+
+The function irGroup then propagates role information until it reaches a
+fixpoint, preferring N over R, P and R over P. To aid in this, we have a monad
+RoleM, which is a combination reader and state monad. In its state are the
+current RoleEnv, which gets updated by role propagation, and an update bit,
+which we use to know whether or not we've reached the fixpoint. The
+environment of RoleM contains the tycon whose parameters we are inferring, and
+a VarEnv from parameters to their positions, so we can update the RoleEnv.
+Between tycons, this reader information is missing; it is added by
+addRoleInferenceInfo.
+
+There are two kinds of tycons to consider: algebraic ones (including classes)
+and type synonyms. (Remember, families don't participate -- all their parameters
+are N.) An algebraic tycon processes each of its datacons, in turn. Note that
+a datacon's universally quantified parameters might be different from the parent
+tycon's parameters, so we use the datacon's univ parameters in the mapping from
+vars to positions. Note also that we don't want to infer roles for existentials
+(they're all at N, too), so we put them in the set of local variables. As an
+optimisation, we skip any tycons whose roles are already all Nominal, as there
+nowhere else for them to go. For synonyms, we just analyse their right-hand sides.
+
+irType walks through a type, looking for uses of a variable of interest and
+propagating role information. Because anything used under a phantom position
+is at phantom and anything used under a nominal position is at nominal, the
+irType function can assume that anything it sees is at representational. (The
+other possibilities are pruned when they're encountered.)
+
+The rest of the code is just plumbing.
+
+How do we know that this algorithm is correct? It should meet the following
+specification:
+
+Let Z be a role context -- a mapping from variables to roles. The following
+rules define the property (Z |- t : r), where t is a type and r is a role:
+
+Z(a) = r' r' <= r
+------------------------- RCVar
+Z |- a : r
+
+---------- RCConst
+Z |- T : r -- T is a type constructor
+
+Z |- t1 : r
+Z |- t2 : N
+-------------- RCApp
+Z |- t1 t2 : r
+
+forall i<=n. (r_i is R or N) implies Z |- t_i : r_i
+roles(T) = r_1 .. r_n
+---------------------------------------------------- RCDApp
+Z |- T t_1 .. t_n : R
+
+Z, a:N |- t : r
+---------------------- RCAll
+Z |- forall a:k.t : r
+
+
+We also have the following rules:
+
+For all datacon_i in type T, where a_1 .. a_n are universally quantified
+and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p,
+then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R,
+then roles(T) = r_1 .. r_n
+
+roles(->) = R, R
+roles(~#) = N, N
+
+With -dcore-lint on, the output of this algorithm is checked in checkValidRoles,
+called from checkValidTycon.
+
+\begin{code}
+type RoleEnv = NameEnv [Role] -- from tycon names to roles
+type RoleAnnots = NameEnv [Maybe Role] -- from tycon names to role annotations,
+ -- which may be left out
+
+-- This, and any of the functions it calls, must *not* look at the roles
+-- field of a tycon we are inferring roles about!
+-- See Note [Role inference]
+inferRoles :: RoleAnnots -> [TyCon] -> Name -> [Role]
+inferRoles annots tycons
+ = let role_env = initialRoleEnv annots tycons
+ role_env' = irGroup role_env tycons in
+ \name -> case lookupNameEnv role_env' name of
+ Just roles -> roles
+ Nothing -> pprPanic "inferRoles" (ppr name)
+
+initialRoleEnv :: RoleAnnots -> [TyCon] -> RoleEnv
+initialRoleEnv annots = extendNameEnvList emptyNameEnv .
+ map (initialRoleEnv1 annots)
+
+initialRoleEnv1 :: RoleAnnots -> TyCon -> (Name, [Role])
+initialRoleEnv1 annots_env tc
+ | isFamilyTyCon tc = (name, map (const Nominal) tyvars)
+ | isAlgTyCon tc
+ || isSynTyCon tc = (name, default_roles)
+ | otherwise = pprPanic "initialRoleEnv1" (ppr tc)
+ where name = tyConName tc
+ tyvars = tyConTyVars tc
+
+ -- whether are not there are annotations, we're guaranteed that
+ -- the length of role_annots is appropriate
+ role_annots = case lookupNameEnv annots_env name of
+ Just annots -> annots
+ Nothing -> pprPanic "initialRoleEnv1 annots" (ppr name)
+ default_roles = let kvs = takeWhile isKindVar tyvars in
+ map (const Nominal) kvs ++
+ zipWith orElse role_annots (repeat Phantom)
+
+irGroup :: RoleEnv -> [TyCon] -> RoleEnv
+irGroup env tcs
+ = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in
+ if update
+ then irGroup env' tcs
+ else env'
+
+irTyCon :: TyCon -> RoleM ()
+irTyCon tc
+ | isAlgTyCon tc
+ = do { old_roles <- lookupRoles tc
+ ; unless (all (== Nominal) old_roles) $ -- also catches data families,
+ -- which don't want or need role inference
+ do { whenIsJust (tyConClass_maybe tc) (irClass tc_name)
+ ; mapM_ (irDataCon tc_name) (visibleDataCons $ algTyConRhs tc) }}
+
+ | Just (SynonymTyCon ty) <- synTyConRhs_maybe tc
+ = addRoleInferenceInfo tc_name (tyConTyVars tc) $
+ irType emptyVarSet ty
+
+ | otherwise
+ = return ()
+
+ where
+ tc_name = tyConName tc
+
+-- any type variable used in an associated type must be Nominal
+irClass :: Name -> Class -> RoleM ()
+irClass tc_name cls
+ = addRoleInferenceInfo tc_name cls_tvs $
+ mapM_ ir_at (classATs cls)
+ where
+ cls_tvs = classTyVars cls
+ cls_tv_set = mkVarSet cls_tvs
+
+ ir_at at_tc
+ = mapM_ (updateRole Nominal) (varSetElems nvars)
+ where nvars = (mkVarSet $ tyConTyVars at_tc) `intersectVarSet` cls_tv_set
+
+-- See Note [Role inference]
+irDataCon :: Name -> DataCon -> RoleM ()
+irDataCon tc_name datacon
+ = addRoleInferenceInfo tc_name (dataConUnivTyVars datacon) $
+ let ex_var_set = mkVarSet $ dataConExTyVars datacon in
+ mapM_ (irType ex_var_set) (dataConRepArgTys datacon)
+
+irType :: VarSet -> Type -> RoleM ()
+irType = go
+ where
+ go lcls (TyVarTy tv) = unless (tv `elemVarSet` lcls) $
+ updateRole Representational tv
+ go lcls (AppTy t1 t2) = go lcls t1 >> mark_nominal lcls t2
+ go lcls (TyConApp tc tys)
+ = do { roles <- lookupRolesX tc
+ ; zipWithM_ (go_app lcls) roles tys }
+ go lcls (FunTy t1 t2) = go lcls t1 >> go lcls t2
+ go lcls (ForAllTy tv ty) = go (extendVarSet lcls tv) ty
+ go _ (LitTy {}) = return ()
+
+ go_app _ Phantom _ = return () -- nothing to do here
+ go_app lcls Nominal ty = mark_nominal lcls ty -- all vars below here are N
+ go_app lcls Representational ty = go lcls ty
+
+ mark_nominal lcls ty = let nvars = tyVarsOfType ty `minusVarSet` lcls in
+ mapM_ (updateRole Nominal) (varSetElems nvars)
+
+-- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps
+lookupRolesX :: TyCon -> RoleM [Role]
+lookupRolesX tc
+ = do { roles <- lookupRoles tc
+ ; return $ roles ++ repeat Nominal }
+
+-- gets the roles either from the environment or the tycon
+lookupRoles :: TyCon -> RoleM [Role]
+lookupRoles tc
+ = do { env <- getRoleEnv
+ ; case lookupNameEnv env (tyConName tc) of
+ Just roles -> return roles
+ Nothing -> return $ tyConRoles tc }
+
+-- tries to update a role; won't even update a role "downwards"
+updateRole :: Role -> TyVar -> RoleM ()
+updateRole role tv
+ = do { var_ns <- getVarNs
+ ; case lookupVarEnv var_ns tv of
+ { Nothing -> pprPanic "updateRole" (ppr tv)
+ ; Just n -> do
+ { name <- getTyConName
+ ; updateRoleEnv name n role }}}
+
+-- the state in the RoleM monad
+data RoleInferenceState = RIS { role_env :: RoleEnv
+ , update :: Bool }
+
+-- the environment in the RoleM monad
+type VarPositions = VarEnv Int
+data RoleInferenceInfo = RII { var_ns :: VarPositions
+ , name :: Name }
+
+-- See [Role inference]
+newtype RoleM a = RM { unRM :: Maybe RoleInferenceInfo
+ -> RoleInferenceState
+ -> (a, RoleInferenceState) }
+instance Monad RoleM where
+ return x = RM $ \_ state -> (x, state)
+ a >>= f = RM $ \m_info state -> let (a', state') = unRM a m_info state in
+ unRM (f a') m_info state'
+
+runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool)
+runRoleM env thing = (env', update)
+ where RIS { role_env = env', update = update } = snd $ unRM thing Nothing state
+ state = RIS { role_env = env, update = False }
+
+addRoleInferenceInfo :: Name -> [TyVar] -> RoleM a -> RoleM a
+addRoleInferenceInfo name tvs thing
+ = RM $ \_nothing state -> ASSERT( isNothing _nothing )
+ unRM thing (Just info) state
+ where info = RII { var_ns = mkVarEnv (zip tvs [0..]), name = name }
+
+getRoleEnv :: RoleM RoleEnv
+getRoleEnv = RM $ \_ state@(RIS { role_env = env }) -> (env, state)
+
+getVarNs :: RoleM VarPositions
+getVarNs = RM $ \m_info state ->
+ case m_info of
+ Nothing -> panic "getVarNs"
+ Just (RII { var_ns = var_ns }) -> (var_ns, state)
+
+getTyConName :: RoleM Name
+getTyConName = RM $ \m_info state ->
+ case m_info of
+ Nothing -> panic "getTyConName"
+ Just (RII { name = name }) -> (name, state)
+
+
+updateRoleEnv :: Name -> Int -> Role -> RoleM ()
+updateRoleEnv name n role
+ = RM $ \_ state@(RIS { role_env = role_env }) -> ((),
+ case lookupNameEnv role_env name of
+ Nothing -> pprPanic "updateRoleEnv" (ppr name)
+ Just roles -> let (before, old_role : after) = splitAt n roles in
+ if role `ltRole` old_role
+ then let roles' = before ++ role : after
+ role_env' = extendNameEnv role_env name roles' in
+ RIS { role_env = role_env', update = True }
+ else state )
+
+\end{code}
%************************************************************************
%* *
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index a3d3156d3f..8a8de41159 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -1330,18 +1330,19 @@ orphNamesOfDFunHead dfun_ty
(_, _, head_ty) -> orphNamesOfType head_ty
orphNamesOfCo :: Coercion -> NameSet
-orphNamesOfCo (Refl ty) = orphNamesOfType ty
-orphNamesOfCo (TyConAppCo tc cos) = unitNameSet (getName tc) `unionNameSets` orphNamesOfCos cos
+orphNamesOfCo (Refl _ ty) = orphNamesOfType ty
+orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSets` orphNamesOfCos cos
orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
orphNamesOfCo (ForAllCo _ co) = orphNamesOfCo co
orphNamesOfCo (CoVarCo _) = emptyNameSet
orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSets` orphNamesOfCos cos
-orphNamesOfCo (UnsafeCo ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
+orphNamesOfCo (UnivCo _ ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
orphNamesOfCo (SymCo co) = orphNamesOfCo co
orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
orphNamesOfCo (NthCo _ co) = orphNamesOfCo co
orphNamesOfCo (LRCo _ co) = orphNamesOfCo co
orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSets` orphNamesOfType ty
+orphNamesOfCo (SubCo co) = orphNamesOfCo co
orphNamesOfCos :: [Coercion] -> NameSet
orphNamesOfCos = orphNamesOfThings orphNamesOfCo
diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index 312ce84525..7a1251f8ea 100644
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -143,15 +143,15 @@ parent class. Thus
type F b x a :: *
We make F use the same Name for 'a' as C does, and similary 'b'.
-The only reason for this is when checking instances it's easier to match
+The reason for this is when checking instances it's easier to match
them up, to ensure they match. Eg
instance C Int [d] where
type F [d] x Int = ....
we should make sure that the first and third args match the instance
header.
-This is the reason we use the Name and TyVar from the parent declaration,
-in both class and instance decls: just to make this check easier.
+Having the same variables for class and tycon is also used in checkValidRoles
+(in TcTyClsDecls) when checking a class's roles.
%************************************************************************
diff --git a/compiler/types/CoAxiom.lhs b/compiler/types/CoAxiom.lhs
index 7781d56356..e507607cd3 100644
--- a/compiler/types/CoAxiom.lhs
+++ b/compiler/types/CoAxiom.lhs
@@ -21,10 +21,12 @@ module CoAxiom (
toBranchedAxiom, toUnbranchedAxiom,
coAxiomName, coAxiomArity, coAxiomBranches,
coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats,
- coAxiomNthBranch, coAxiomSingleBranch_maybe,
- coAxiomSingleBranch, coAxBranchTyVars, coAxBranchLHS,
- coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps,
- placeHolderIncomps
+ coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole,
+ coAxiomSingleBranch, coAxBranchTyVars, coAxBranchRoles,
+ coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps,
+ placeHolderIncomps,
+
+ Role(..)
) where
import {-# SOURCE #-} TypeRep ( Type )
@@ -34,6 +36,7 @@ import Name
import Unique
import Var
import Util
+import Binary
import BasicTypes
import Data.Typeable ( Typeable )
import SrcLoc
@@ -233,6 +236,7 @@ data CoAxiom br
= CoAxiom -- Type equality axiom.
{ co_ax_unique :: Unique -- unique identifier
, co_ax_name :: Name -- name for pretty-printing
+ , co_ax_role :: Role -- role of the axiom's equality
, co_ax_tc :: TyCon -- the head of the LHS patterns
, co_ax_branches :: BranchList CoAxBranch br
-- the branches that form this axiom
@@ -248,6 +252,7 @@ data CoAxBranch
-- See Note [CoAxiom locations]
, cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh
-- See Note [CoAxBranch type variables]
+ , cab_roles :: [Role] -- See Note [CoAxBranch roles]
, cab_lhs :: [Type] -- Type patterns to match against
, cab_rhs :: Type -- Right-hand side of the equality
, cab_incomps :: [CoAxBranch] -- The previous incompatible branches
@@ -256,12 +261,12 @@ data CoAxBranch
deriving Typeable
toBranchedAxiom :: CoAxiom br -> CoAxiom Branched
-toBranchedAxiom (CoAxiom unique name tc branches implicit)
- = CoAxiom unique name tc (toBranchedList branches) implicit
+toBranchedAxiom (CoAxiom unique name role tc branches implicit)
+ = CoAxiom unique name role tc (toBranchedList branches) implicit
toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched
-toUnbranchedAxiom (CoAxiom unique name tc branches implicit)
- = CoAxiom unique name tc (toUnbranchedList branches) implicit
+toUnbranchedAxiom (CoAxiom unique name role tc branches implicit)
+ = CoAxiom unique name role tc (toUnbranchedList branches) implicit
coAxiomNumPats :: CoAxiom br -> Int
coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0)
@@ -277,6 +282,9 @@ coAxiomArity ax index
coAxiomName :: CoAxiom br -> Name
coAxiomName = co_ax_name
+coAxiomRole :: CoAxiom br -> Role
+coAxiomRole = co_ax_role
+
coAxiomBranches :: CoAxiom br -> BranchList CoAxBranch br
coAxiomBranches = co_ax_branches
@@ -302,6 +310,9 @@ coAxBranchLHS = cab_lhs
coAxBranchRHS :: CoAxBranch -> Type
coAxBranchRHS = cab_rhs
+coAxBranchRoles :: CoAxBranch -> [Role]
+coAxBranchRoles = cab_roles
+
coAxBranchSpan :: CoAxBranch -> SrcSpan
coAxBranchSpan = cab_loc
@@ -338,6 +349,29 @@ class decl, we use the same 'b' to make the same check easy.
So, unlike FamInsts, there is no expectation that the cab_tvs
are fresh wrt each other, or any other CoAxBranch.
+Note [CoAxBranch roles]
+~~~~~~~~~~~~~~~~~~~~~~~
+Consider this code:
+
+ newtype Age = MkAge Int
+ newtype Wrap a = MkWrap a
+
+ convert :: Wrap Age -> Int
+ convert (MkWrap (MkAge i)) = i
+
+We want this to compile to:
+
+ NTCo:Wrap :: forall a. Wrap a ~R a
+ NTCo:Age :: Age ~R Int
+ convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0])
+
+But, note that NTCo:Age is at role R. Thus, we need to be able to pass
+coercions at role R into axioms. However, we don't *always* want to be able to
+do this, as it would be disastrous with type families. The solution is to
+annotate the arguments to the axiom with roles, much like we annotate tycon
+tyvars. Where do these roles get set? Newtype axioms inherit their roles from
+the newtype tycon; family axioms are all at role N.
+
Note [CoAxiom locations]
~~~~~~~~~~~~~~~~~~~~~~~~
The source location of a CoAxiom is stored in two places in the
@@ -391,3 +425,35 @@ instance Typeable br => Data.Data (CoAxiom br) where
dataTypeOf _ = mkNoRepType "CoAxiom"
\end{code}
+%************************************************************************
+%* *
+ Roles
+%* *
+%************************************************************************
+
+This is defined here to avoid circular dependencies.
+
+\begin{code}
+
+-- See Note [Roles] in Coercion
+-- defined here to avoid cyclic dependency with Coercion
+data Role = Nominal | Representational | Phantom
+ deriving (Eq, Data.Data, Data.Typeable)
+
+instance Outputable Role where
+ ppr Nominal = char 'N'
+ ppr Representational = char 'R'
+ ppr Phantom = char 'P'
+
+instance Binary Role where
+ put_ bh Nominal = putByte bh 1
+ put_ bh Representational = putByte bh 2
+ put_ bh Phantom = putByte bh 3
+
+ get bh = do tag <- getByte bh
+ case tag of 1 -> return Nominal
+ 2 -> return Representational
+ 3 -> return Phantom
+ _ -> panic ("get Role " ++ show tag)
+
+\end{code} \ No newline at end of file
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 0c85667e2f..6cda16b9ec 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -18,11 +18,12 @@ module Coercion (
-- * Main data type
Coercion(..), Var, CoVar,
LeftOrRight(..), pickLR,
+ Role(..), ltRole,
-- ** Functions over coercions
- coVarKind,
+ coVarKind, coVarRole,
coercionType, coercionKind, coercionKinds, isReflCo,
- isReflCo_maybe,
+ isReflCo_maybe, coercionRole,
mkCoercionType,
-- ** Constructing coercions
@@ -30,19 +31,19 @@ module Coercion (
mkAxInstCo, mkUnbranchedAxInstCo, mkAxInstLHS, mkAxInstRHS,
mkUnbranchedAxInstRHS,
mkPiCo, mkPiCos, mkCoCast,
- mkSymCo, mkTransCo, mkNthCo, mkLRCo,
+ mkSymCo, mkTransCo, mkNthCo, mkNthCoRole, mkLRCo,
mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo,
- mkForAllCo, mkUnsafeCo,
- mkNewTypeCo,
+ mkForAllCo, mkUnsafeCo, mkUnivCo, mkSubCo, mkPhantomCo,
+ mkNewTypeCo, maybeSubCo, maybeSubCo2,
-- ** Decomposition
splitNewTypeRepCo_maybe, instNewTyCon_maybe,
topNormaliseNewType, topNormaliseNewTypeX,
decomposeCo, getCoVar_maybe,
- splitTyConAppCo_maybe,
splitAppCo_maybe,
splitForAllCo_maybe,
+ nthRole, tyConRolesX,
-- ** Coercion variables
mkCoVar, isCoVar, isCoVarType, coVarName, setCoVarName, setCoVarUnique,
@@ -57,7 +58,8 @@ module Coercion (
substCo, substCos, substCoVar, substCoVars,
substCoWithTy, substCoWithTys,
cvTvSubst, tvCvSubst, mkCvSubst, zipOpenCvSubst,
- substTy, extendTvSubst, extendCvSubstAndInScope,
+ substTy, extendTvSubst,
+ extendCvSubstAndInScope, extendTvSubstAndInScope,
substTyVarBndr, substCoVarBndr,
-- ** Lifting
@@ -101,10 +103,9 @@ import Outputable
import Unique
import Pair
import SrcLoc
-import PrelNames ( funTyConKey, eqPrimTyConKey )
+import PrelNames ( funTyConKey, eqPrimTyConKey, eqReprPrimTyConKey )
import Control.Applicative
import Data.Traversable (traverse, sequenceA)
-import Control.Arrow (second)
import FastString
import qualified Data.Data as Data hiding ( TyCon )
@@ -123,8 +124,16 @@ import qualified Data.Data as Data hiding ( TyCon )
-- If you edit this type, you may need to update the GHC formalism
-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs
data Coercion
+ -- Each constructor has a "role signature", indicating the way roles are
+ -- propagated through coercions. P, N, and R stand for coercions of the
+ -- given role. e stands for a coercion of a specific unknown role (think
+ -- "role polymorphism"). "e" stands for an explicit role parameter
+ -- indicating role e. _ stands for a parameter that is not a Role or
+ -- Coercion.
+
-- These ones mirror the shape of types
- = Refl Type -- See Note [Refl invariant]
+ = -- Refl :: "e" -> _ -> e
+ Refl Role Type -- See Note [Refl invariant]
-- Invariant: applications of (Refl T) to a bunch of identity coercions
-- always show up as Refl.
-- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)).
@@ -135,20 +144,30 @@ data Coercion
-- ConAppCo coercions (like all coercions other than Refl)
-- are NEVER the identity.
+ -- Use (Refl Representational _), not (SubCo (Refl Nominal _))
+
-- These ones simply lift the correspondingly-named
-- Type constructors into Coercions
- | TyConAppCo TyCon [Coercion] -- lift TyConApp
+
+ -- TyConAppCo :: "e" -> _ -> ?? -> e
+ -- See Note [TyConAppCo roles]
+ | TyConAppCo Role TyCon [Coercion] -- lift TyConApp
-- The TyCon is never a synonym;
-- we expand synonyms eagerly
-- But it can be a type function
| AppCo Coercion Coercion -- lift AppTy
+ -- AppCo :: e -> N -> e
-- See Note [Forall coercions]
| ForAllCo TyVar Coercion -- forall a. g
+ -- :: _ -> e -> e
-- These are special
- | CoVarCo CoVar
+ | CoVarCo CoVar -- :: _ -> (N or R)
+ -- result role depends on the tycon of the variable's type
+
+ -- AxiomInstCo :: e -> _ -> [N] -> e
| AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion]
-- See also [CoAxiom index]
-- The coercion arguments always *precisely* saturate
@@ -156,14 +175,22 @@ data Coercion
-- any left over, we use AppCo. See
-- See [Coercion axioms applied to coercions]
- | UnsafeCo Type Type
- | SymCo Coercion
- | TransCo Coercion Coercion
+ -- see Note [UnivCo]
+ | UnivCo Role Type Type -- :: "e" -> _ -> _ -> e
+ | SymCo Coercion -- :: e -> e
+ | TransCo Coercion Coercion -- :: e -> e -> e
-- These are destructors
+
| NthCo Int Coercion -- Zero-indexed; decomposes (T t0 ... tn)
+ -- :: _ -> e -> ?? (inverse of TyConAppCo, see Note [TyConAppCo roles])
| LRCo LeftOrRight Coercion -- Decomposes (t_left t_right)
+ -- :: _ -> N -> N
| InstCo Coercion Type
+ -- :: e -> _ -> e
+
+ | SubCo Coercion -- Turns a ~N into a ~R
+ -- :: N -> R
deriving (Data.Data, Data.Typeable)
-- If you edit this type, you may need to update the GHC formalism
@@ -185,7 +212,6 @@ pickLR CLeft (l,_) = l
pickLR CRight (_,r) = r
\end{code}
-
Note [Refl invariant]
~~~~~~~~~~~~~~~~~~~~~
Coercions have the following invariant
@@ -323,6 +349,142 @@ may turn into
C (Nth 0 g) ....
Now (Nth 0 g) will optimise to Refl, but perhaps not instantly.
+Note [Roles]
+~~~~~~~~~~~~
+Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated
+in Trac #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see
+http://ghc.haskell.org/trac/ghc/wiki/RolesImplementation
+
+Here is one way to phrase the problem:
+
+Given:
+newtype Age = MkAge Int
+type family F x
+type instance F Age = Bool
+type instance F Int = Char
+
+This compiles down to:
+axAge :: Age ~ Int
+axF1 :: F Age ~ Bool
+axF2 :: F Int ~ Char
+
+Then, we can make:
+(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char
+
+Yikes!
+
+The solution is _roles_, as articulated in "Generative Type Abstraction and
+Type-level Computation" (POPL 2010), available at
+http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf
+
+The specification for roles has evolved somewhat since that paper. For the
+current full details, see the documentation in docs/core-spec. Here are some
+highlights.
+
+We label every equality with a notion of type equivalence, of which there are
+three options: Nominal, Representational, and Phantom. A ground type is
+nominally equivalent only with itself. A newtype (which is considered a ground
+type in Haskell) is representationally equivalent to its representation.
+Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P"
+to denote the equivalences.
+
+The axioms above would be:
+axAge :: Age ~R Int
+axF1 :: F Age ~N Bool
+axF2 :: F Age ~N Char
+
+Then, because transitivity applies only to coercions proving the same notion
+of equivalence, the above construction is impossible.
+
+However, there is still an escape hatch: we know that any two types that are
+nominally equivalent are representationally equivalent as well. This is what
+the form SubCo proves -- it "demotes" a nominal equivalence into a
+representational equivalence. So, it would seem the following is possible:
+
+sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG
+
+What saves us here is that the arguments to a type function F, lifted into a
+coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and
+we are safe.
+
+Roles are attached to parameters to TyCons. When lifting a TyCon into a
+coercion (through TyConAppCo), we need to ensure that the arguments to the
+TyCon respect their roles. For example:
+
+data T a b = MkT a (F b)
+
+If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know
+that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because
+the type function F branches on b's *name*, not representation. So, we say
+that 'a' has role Representational and 'b' has role Nominal. The third role,
+Phantom, is for parameters not used in the type's definition. Given the
+following definition
+
+data Q a = MkQ Int
+
+the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we
+can construct the coercion Bool ~P Char (using UnivCo).
+
+See the paper cited above for more examples and information.
+
+Note [UnivCo]
+~~~~~~~~~~~~~
+The UnivCo ("universal coercion") serves two rather separate functions:
+ - the implementation for unsafeCoerce#
+ - placeholder for phantom parameters in a TyConAppCo
+
+At Representational, it asserts that two (possibly unrelated)
+types have the same representation and can be casted to one another.
+This form is necessary for unsafeCoerce#.
+
+For optimisation purposes, it is convenient to allow UnivCo to appear
+at Nominal role. If we have
+
+data Foo a = MkFoo (F a) -- F is a type family
+
+and we want an unsafe coercion from Foo Int to Foo Bool, then it would
+be nice to have (TyConAppCo Foo (UnivCo Nominal Int Bool)). So, we allow
+Nominal UnivCo's.
+
+At Phantom role, it is used as an argument to TyConAppCo in the place
+of a phantom parameter (a type parameter unused in the type definition).
+
+For example:
+
+data Q a = MkQ Int
+
+We want a coercion for (Q Bool) ~R (Q Char).
+
+(TyConAppCo Representational Q [UnivCo Phantom Bool Char]) does the trick.
+
+Note [TyConAppCo roles]
+~~~~~~~~~~~~~~~~~~~~~~~
+The TyConAppCo constructor has a role parameter, indicating the role at
+which the coercion proves equality. The choice of this parameter affects
+the required roles of the arguments of the TyConAppCo. To help explain
+it, assume the following definition:
+
+newtype Age = MkAge Int
+
+Nominal: All arguments must have role Nominal. Why? So that Foo Age ~N Foo Int
+does *not* hold.
+
+Representational: All arguments must have the roles corresponding to the
+result of tyConRoles on the TyCon. This is the whole point of having
+roles on the TyCon to begin with. So, we can have Foo Age ~R Foo Int,
+if Foo's parameter has role R.
+
+If a Representational TyConAppCo is over-saturated (which is otherwise fine),
+the spill-over arguments must all be at Nominal. This corresponds to the
+behavior for AppCo.
+
+Phantom: All arguments must have role Phantom. This one isn't strictly
+necessary for soundness, but this choice removes ambiguity.
+
+
+
+The rules here also dictate what the parameters to mkTyConAppCo.
+
%************************************************************************
%* *
\subsection{Coercion variables}
@@ -345,7 +507,8 @@ isCoVar v = isCoVarType (varType v)
isCoVarType :: Type -> Bool
isCoVarType ty -- Tests for t1 ~# t2, the unboxed equality
= case splitTyConApp_maybe ty of
- Just (tc,tys) -> tc `hasKey` eqPrimTyConKey && tys `lengthAtLeast` 2
+ Just (tc,tys) -> (tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey)
+ && tys `lengthAtLeast` 2
Nothing -> False
\end{code}
@@ -353,53 +516,56 @@ isCoVarType ty -- Tests for t1 ~# t2, the unboxed equality
\begin{code}
tyCoVarsOfCo :: Coercion -> VarSet
-- Extracts type and coercion variables from a coercion
-tyCoVarsOfCo (Refl ty) = tyVarsOfType ty
-tyCoVarsOfCo (TyConAppCo _ cos) = tyCoVarsOfCos cos
-tyCoVarsOfCo (AppCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
-tyCoVarsOfCo (ForAllCo tv co) = tyCoVarsOfCo co `delVarSet` tv
-tyCoVarsOfCo (CoVarCo v) = unitVarSet v
+tyCoVarsOfCo (Refl _ ty) = tyVarsOfType ty
+tyCoVarsOfCo (TyConAppCo _ _ cos) = tyCoVarsOfCos cos
+tyCoVarsOfCo (AppCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
+tyCoVarsOfCo (ForAllCo tv co) = tyCoVarsOfCo co `delVarSet` tv
+tyCoVarsOfCo (CoVarCo v) = unitVarSet v
tyCoVarsOfCo (AxiomInstCo _ _ cos) = tyCoVarsOfCos cos
-tyCoVarsOfCo (UnsafeCo ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
-tyCoVarsOfCo (SymCo co) = tyCoVarsOfCo co
-tyCoVarsOfCo (TransCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
-tyCoVarsOfCo (NthCo _ co) = tyCoVarsOfCo co
-tyCoVarsOfCo (LRCo _ co) = tyCoVarsOfCo co
-tyCoVarsOfCo (InstCo co ty) = tyCoVarsOfCo co `unionVarSet` tyVarsOfType ty
+tyCoVarsOfCo (UnivCo _ ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+tyCoVarsOfCo (SymCo co) = tyCoVarsOfCo co
+tyCoVarsOfCo (TransCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
+tyCoVarsOfCo (NthCo _ co) = tyCoVarsOfCo co
+tyCoVarsOfCo (LRCo _ co) = tyCoVarsOfCo co
+tyCoVarsOfCo (InstCo co ty) = tyCoVarsOfCo co `unionVarSet` tyVarsOfType ty
+tyCoVarsOfCo (SubCo co) = tyCoVarsOfCo co
tyCoVarsOfCos :: [Coercion] -> VarSet
tyCoVarsOfCos cos = foldr (unionVarSet . tyCoVarsOfCo) emptyVarSet cos
coVarsOfCo :: Coercion -> VarSet
-- Extract *coerction* variables only. Tiresome to repeat the code, but easy.
-coVarsOfCo (Refl _) = emptyVarSet
-coVarsOfCo (TyConAppCo _ cos) = coVarsOfCos cos
-coVarsOfCo (AppCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
-coVarsOfCo (ForAllCo _ co) = coVarsOfCo co
-coVarsOfCo (CoVarCo v) = unitVarSet v
+coVarsOfCo (Refl _ _) = emptyVarSet
+coVarsOfCo (TyConAppCo _ _ cos) = coVarsOfCos cos
+coVarsOfCo (AppCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
+coVarsOfCo (ForAllCo _ co) = coVarsOfCo co
+coVarsOfCo (CoVarCo v) = unitVarSet v
coVarsOfCo (AxiomInstCo _ _ cos) = coVarsOfCos cos
-coVarsOfCo (UnsafeCo _ _) = emptyVarSet
-coVarsOfCo (SymCo co) = coVarsOfCo co
-coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
-coVarsOfCo (NthCo _ co) = coVarsOfCo co
-coVarsOfCo (LRCo _ co) = coVarsOfCo co
-coVarsOfCo (InstCo co _) = coVarsOfCo co
+coVarsOfCo (UnivCo _ _ _) = emptyVarSet
+coVarsOfCo (SymCo co) = coVarsOfCo co
+coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
+coVarsOfCo (NthCo _ co) = coVarsOfCo co
+coVarsOfCo (LRCo _ co) = coVarsOfCo co
+coVarsOfCo (InstCo co _) = coVarsOfCo co
+coVarsOfCo (SubCo co) = coVarsOfCo co
coVarsOfCos :: [Coercion] -> VarSet
coVarsOfCos cos = foldr (unionVarSet . coVarsOfCo) emptyVarSet cos
coercionSize :: Coercion -> Int
-coercionSize (Refl ty) = typeSize ty
-coercionSize (TyConAppCo _ cos) = 1 + sum (map coercionSize cos)
-coercionSize (AppCo co1 co2) = coercionSize co1 + coercionSize co2
-coercionSize (ForAllCo _ co) = 1 + coercionSize co
-coercionSize (CoVarCo _) = 1
+coercionSize (Refl _ ty) = typeSize ty
+coercionSize (TyConAppCo _ _ cos) = 1 + sum (map coercionSize cos)
+coercionSize (AppCo co1 co2) = coercionSize co1 + coercionSize co2
+coercionSize (ForAllCo _ co) = 1 + coercionSize co
+coercionSize (CoVarCo _) = 1
coercionSize (AxiomInstCo _ _ cos) = 1 + sum (map coercionSize cos)
-coercionSize (UnsafeCo ty1 ty2) = typeSize ty1 + typeSize ty2
-coercionSize (SymCo co) = 1 + coercionSize co
-coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2
-coercionSize (NthCo _ co) = 1 + coercionSize co
-coercionSize (LRCo _ co) = 1 + coercionSize co
-coercionSize (InstCo co ty) = 1 + coercionSize co + typeSize ty
+coercionSize (UnivCo _ ty1 ty2) = typeSize ty1 + typeSize ty2
+coercionSize (SymCo co) = 1 + coercionSize co
+coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2
+coercionSize (NthCo _ co) = 1 + coercionSize co
+coercionSize (LRCo _ co) = 1 + coercionSize co
+coercionSize (InstCo co ty) = 1 + coercionSize co + typeSize ty
+coercionSize (SubCo co) = 1 + coercionSize co
\end{code}
%************************************************************************
@@ -413,24 +579,25 @@ tidyCo :: TidyEnv -> Coercion -> Coercion
tidyCo env@(_, subst) co
= go co
where
- go (Refl ty) = Refl (tidyType env ty)
- go (TyConAppCo tc cos) = let args = map go cos
- in args `seqList` TyConAppCo tc args
- go (AppCo co1 co2) = (AppCo $! go co1) $! go co2
- go (ForAllCo tv co) = ForAllCo tvp $! (tidyCo envp co)
- where
- (envp, tvp) = tidyTyVarBndr env tv
- go (CoVarCo cv) = case lookupVarEnv subst cv of
- Nothing -> CoVarCo cv
- Just cv' -> CoVarCo cv'
+ go (Refl r ty) = Refl r (tidyType env ty)
+ go (TyConAppCo r tc cos) = let args = map go cos
+ in args `seqList` TyConAppCo r tc args
+ go (AppCo co1 co2) = (AppCo $! go co1) $! go co2
+ go (ForAllCo tv co) = ForAllCo tvp $! (tidyCo envp co)
+ where
+ (envp, tvp) = tidyTyVarBndr env tv
+ go (CoVarCo cv) = case lookupVarEnv subst cv of
+ Nothing -> CoVarCo cv
+ Just cv' -> CoVarCo cv'
go (AxiomInstCo con ind cos) = let args = tidyCos env cos
- in args `seqList` AxiomInstCo con ind args
- go (UnsafeCo ty1 ty2) = (UnsafeCo $! tidyType env ty1) $! tidyType env ty2
- go (SymCo co) = SymCo $! go co
- go (TransCo co1 co2) = (TransCo $! go co1) $! go co2
- go (NthCo d co) = NthCo d $! go co
- go (LRCo lr co) = LRCo lr $! go co
- go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty
+ in args `seqList` AxiomInstCo con ind args
+ go (UnivCo r ty1 ty2) = (UnivCo r $! tidyType env ty1) $! tidyType env ty2
+ go (SymCo co) = SymCo $! go co
+ go (TransCo co1 co2) = (TransCo $! go co1) $! go co2
+ go (NthCo d co) = NthCo d $! go co
+ go (LRCo lr co) = LRCo lr $! go co
+ go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty
+ go (SubCo co) = SubCo $! go co
tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
tidyCos env = map (tidyCo env)
@@ -457,16 +624,16 @@ pprCo co = ppr_co TopPrec co
pprParendCo co = ppr_co TyConPrec co
ppr_co :: Prec -> Coercion -> SDoc
-ppr_co _ (Refl ty) = angleBrackets (ppr ty)
+ppr_co _ (Refl r ty) = angleBrackets (ppr ty) <> ppr_role r
-ppr_co p co@(TyConAppCo tc [_,_])
+ppr_co p co@(TyConAppCo _ tc [_,_])
| tc `hasKey` funTyConKey = ppr_fun_co p co
-ppr_co p (TyConAppCo tc cos) = pprTcApp p ppr_co tc cos
-ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $
- pprCo co1 <+> ppr_co TyConPrec co2
-ppr_co p co@(ForAllCo {}) = ppr_forall_co p co
-ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv)
+ppr_co _ (TyConAppCo r tc cos) = pprTcApp TyConPrec ppr_co tc cos <> ppr_role r
+ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $
+ pprCo co1 <+> ppr_co TyConPrec co2
+ppr_co p co@(ForAllCo {}) = ppr_forall_co p co
+ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv)
ppr_co p (AxiomInstCo con index cos)
= pprPrefixApp p (ppr (getName con) <> brackets (ppr index))
(map (ppr_co TyConPrec) cos)
@@ -479,11 +646,15 @@ ppr_co p co@(TransCo {}) = maybeParen p FunPrec $
ppr_co p (InstCo co ty) = maybeParen p TyConPrec $
pprParendCo co <> ptext (sLit "@") <> pprType ty
-ppr_co p (UnsafeCo ty1 ty2) = pprPrefixApp p (ptext (sLit "UnsafeCo"))
+ppr_co p (UnivCo r ty1 ty2) = pprPrefixApp p (ptext (sLit "UnivCo") <+> ppr r)
[pprParendType ty1, pprParendType ty2]
ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co]
ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <> int n) [pprParendCo co]
ppr_co p (LRCo sel co) = pprPrefixApp p (ppr sel) [pprParendCo co]
+ppr_co p (SubCo co) = pprPrefixApp p (ptext (sLit "Sub")) [pprParendCo co]
+
+ppr_role :: Role -> SDoc
+ppr_role r = underscore <> ppr r
trans_co_list :: Coercion -> [Coercion] -> [Coercion]
trans_co_list (TransCo co1 co2) cos = trans_co_list co1 (trans_co_list co2 cos)
@@ -497,7 +668,7 @@ ppr_fun_co :: Prec -> Coercion -> SDoc
ppr_fun_co p co = pprArrowChain p (split co)
where
split :: Coercion -> [SDoc]
- split (TyConAppCo f [arg,res])
+ split (TyConAppCo _ f [arg,res])
| f `hasKey` funTyConKey
= ppr_co FunPrec arg : split res
split co = [ppr_co TopPrec co]
@@ -561,25 +732,20 @@ getCoVar_maybe :: Coercion -> Maybe CoVar
getCoVar_maybe (CoVarCo cv) = Just cv
getCoVar_maybe _ = Nothing
--- | Attempts to tease a coercion apart into a type constructor and the application
--- of a number of coercion arguments to that constructor
-splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])
-splitTyConAppCo_maybe (Refl ty) = (fmap . second . map) Refl (splitTyConApp_maybe ty)
-splitTyConAppCo_maybe (TyConAppCo tc cos) = Just (tc, cos)
-splitTyConAppCo_maybe _ = Nothing
-
+-- first result has role equal to input; second result is Nominal
splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)
-- ^ Attempt to take a coercion application apart.
splitAppCo_maybe (AppCo co1 co2) = Just (co1, co2)
-splitAppCo_maybe (TyConAppCo tc cos)
+splitAppCo_maybe (TyConAppCo r tc cos)
| isDecomposableTyCon tc || cos `lengthExceeds` tyConArity tc
, Just (cos', co') <- snocView cos
- = Just (mkTyConAppCo tc cos', co') -- Never create unsaturated type family apps!
+ , Just co'' <- unSubCo_maybe co'
+ = Just (mkTyConAppCo r tc cos', co'') -- Never create unsaturated type family apps!
-- Use mkTyConAppCo to preserve the invariant
-- that identity coercions are always represented by Refl
-splitAppCo_maybe (Refl ty)
+splitAppCo_maybe (Refl r ty)
| Just (ty1, ty2) <- splitAppTy_maybe ty
- = Just (Refl ty1, Refl ty2)
+ = Just (Refl r ty1, Refl Nominal ty2)
splitAppCo_maybe _ = Nothing
splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion)
@@ -592,22 +758,38 @@ splitForAllCo_maybe _ = Nothing
coVarKind :: CoVar -> (Type,Type)
coVarKind cv
| Just (tc, [_kind,ty1,ty2]) <- splitTyConApp_maybe (varType cv)
- = ASSERT(tc `hasKey` eqPrimTyConKey)
+ = ASSERT(tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey)
(ty1,ty2)
| otherwise = panic "coVarKind, non coercion variable"
+coVarRole :: CoVar -> Role
+coVarRole cv
+ | tc `hasKey` eqPrimTyConKey
+ = Nominal
+ | tc `hasKey` eqReprPrimTyConKey
+ = Representational
+ | otherwise
+ = pprPanic "coVarRole: unknown tycon" (ppr cv)
+
+ where
+ tc = case tyConAppTyCon_maybe (varType cv) of
+ Just tc0 -> tc0
+ Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv)
+
-- | Makes a coercion type from two types: the types whose equality
-- is proven by the relevant 'Coercion'
-mkCoercionType :: Type -> Type -> Type
-mkCoercionType = mkPrimEqPred
+mkCoercionType :: Role -> Type -> Type -> Type
+mkCoercionType Nominal = mkPrimEqPred
+mkCoercionType Representational = mkReprPrimEqPred
+mkCoercionType Phantom = panic "mkCoercionType"
isReflCo :: Coercion -> Bool
-isReflCo (Refl {}) = True
-isReflCo _ = False
+isReflCo (Refl {}) = True
+isReflCo _ = False
isReflCo_maybe :: Coercion -> Maybe Type
-isReflCo_maybe (Refl ty) = Just ty
-isReflCo_maybe _ = Nothing
+isReflCo_maybe (Refl _ ty) = Just ty
+isReflCo_maybe _ = Nothing
\end{code}
%************************************************************************
@@ -620,32 +802,36 @@ isReflCo_maybe _ = Nothing
mkCoVarCo :: CoVar -> Coercion
-- cv :: s ~# t
mkCoVarCo cv
- | ty1 `eqType` ty2 = Refl ty1
+ | ty1 `eqType` ty2 = Refl Nominal ty1
| otherwise = CoVarCo cv
where
(ty1, ty2) = ASSERT( isCoVar cv ) coVarKind cv
-mkReflCo :: Type -> Coercion
+mkReflCo :: Role -> Type -> Coercion
mkReflCo = Refl
-mkAxInstCo :: CoAxiom br -> BranchIndex -> [Type] -> Coercion
+mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> Coercion
-- mkAxInstCo can legitimately be called over-staturated;
-- i.e. with more type arguments than the coercion requires
-mkAxInstCo ax index tys
- | arity == n_tys = AxiomInstCo ax_br index rtys
+mkAxInstCo role ax index tys
+ | arity == n_tys = maybeSubCo2 role ax_role $ AxiomInstCo ax_br index rtys
| otherwise = ASSERT( arity < n_tys )
+ maybeSubCo2 role ax_role $
foldl AppCo (AxiomInstCo ax_br index (take arity rtys))
(drop arity rtys)
where
- n_tys = length tys
- arity = coAxiomArity ax index
- rtys = map Refl tys
- ax_br = toBranchedAxiom ax
+ n_tys = length tys
+ ax_br = toBranchedAxiom ax
+ branch = coAxiomNthBranch ax_br index
+ arity = length $ coAxBranchTyVars branch
+ arg_roles = coAxBranchRoles branch
+ rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys
+ ax_role = coAxiomRole ax
-- to be used only with unbranched axioms
-mkUnbranchedAxInstCo :: CoAxiom Unbranched -> [Type] -> Coercion
-mkUnbranchedAxInstCo ax tys
- = mkAxInstCo ax 0 tys
+mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched -> [Type] -> Coercion
+mkUnbranchedAxInstCo role ax tys
+ = mkAxInstCo role ax 0 tys
mkAxInstLHS, mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> Type
-- Instantiate the axiom with specified types,
@@ -668,41 +854,57 @@ mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> Type
mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0
-- | Apply a 'Coercion' to another 'Coercion'.
+-- The second coercion must be Nominal, unless the first is Phantom.
+-- If the first is Phantom, then the second can be either Phantom or Nominal.
mkAppCo :: Coercion -> Coercion -> Coercion
-mkAppCo (Refl ty1) (Refl ty2) = Refl (mkAppTy ty1 ty2)
-mkAppCo (Refl (TyConApp tc tys)) co = TyConAppCo tc (map Refl tys ++ [co])
-mkAppCo (TyConAppCo tc cos) co = TyConAppCo tc (cos ++ [co])
-mkAppCo co1 co2 = AppCo co1 co2
+mkAppCo (Refl r ty1) (Refl _ ty2)
+ = Refl r (mkAppTy ty1 ty2)
+mkAppCo (Refl r (TyConApp tc tys)) co2
+ = TyConAppCo r tc (zip_roles (tyConRolesX r tc) tys)
+ where
+ zip_roles (r1:_) [] = [applyRole r1 co2]
+ zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys
+ zip_roles _ _ = panic "zip_roles" -- but the roles are infinite...
+mkAppCo (TyConAppCo r tc cos) co
+ = case r of
+ Nominal -> TyConAppCo Nominal tc (cos ++ [co])
+ Representational -> TyConAppCo Representational tc (cos ++ [co'])
+ where new_role = (tyConRolesX Representational tc) !! (length cos)
+ co' = applyRole new_role co
+ Phantom -> TyConAppCo Phantom tc (cos ++ [mkPhantomCo co])
+
+mkAppCo co1 co2 = AppCo co1 co2
-- Note, mkAppCo is careful to maintain invariants regarding
-- where Refl constructors appear; see the comments in the definition
-- of Coercion and the Note [Refl invariant] in types/TypeRep.lhs.
-- | Applies multiple 'Coercion's to another 'Coercion', from left to right.
--- See also 'mkAppCo'
+-- See also 'mkAppCo'.
mkAppCos :: Coercion -> [Coercion] -> Coercion
-mkAppCos co1 tys = foldl mkAppCo co1 tys
+mkAppCos co1 cos = foldl mkAppCo co1 cos
--- | Apply a type constructor to a list of coercions.
-mkTyConAppCo :: TyCon -> [Coercion] -> Coercion
-mkTyConAppCo tc cos
+-- | Apply a type constructor to a list of coercions. It is the
+-- caller's responsibility to get the roles correct on argument coercions.
+mkTyConAppCo :: Role -> TyCon -> [Coercion] -> Coercion
+mkTyConAppCo r tc cos
-- Expand type synonyms
| Just (tv_co_prs, rhs_ty, leftover_cos) <- tcExpandTyCon_maybe tc cos
- = mkAppCos (liftCoSubst tv_co_prs rhs_ty) leftover_cos
+ = mkAppCos (liftCoSubst r tv_co_prs rhs_ty) leftover_cos
| Just tys <- traverse isReflCo_maybe cos
- = Refl (mkTyConApp tc tys) -- See Note [Refl invariant]
+ = Refl r (mkTyConApp tc tys) -- See Note [Refl invariant]
- | otherwise = TyConAppCo tc cos
+ | otherwise = TyConAppCo r tc cos
-- | Make a function 'Coercion' between two other 'Coercion's
-mkFunCo :: Coercion -> Coercion -> Coercion
-mkFunCo co1 co2 = mkTyConAppCo funTyCon [co1, co2]
+mkFunCo :: Role -> Coercion -> Coercion -> Coercion
+mkFunCo r co1 co2 = mkTyConAppCo r funTyCon [co1, co2]
-- | Make a 'Coercion' which binds a variable within an inner 'Coercion'
mkForAllCo :: Var -> Coercion -> Coercion
-- note that a TyVar should be used here, not a CoVar (nor a TcTyVar)
-mkForAllCo tv (Refl ty) = ASSERT( isTyVar tv ) Refl (mkForAllTy tv ty)
-mkForAllCo tv co = ASSERT( isTyVar tv ) ForAllCo tv co
+mkForAllCo tv (Refl r ty) = ASSERT( isTyVar tv ) Refl r (mkForAllTy tv ty)
+mkForAllCo tv co = ASSERT( isTyVar tv ) ForAllCo tv co
-------------------------------
@@ -713,28 +915,40 @@ mkSymCo :: Coercion -> Coercion
-- Do a few simple optimizations, but don't bother pushing occurrences
-- of symmetry to the leaves; the optimizer will take care of that.
-mkSymCo co@(Refl {}) = co
-mkSymCo (UnsafeCo ty1 ty2) = UnsafeCo ty2 ty1
+mkSymCo co@(Refl {}) = co
+mkSymCo (UnivCo r ty1 ty2) = UnivCo r ty2 ty1
mkSymCo (SymCo co) = co
mkSymCo co = SymCo co
-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.
mkTransCo :: Coercion -> Coercion -> Coercion
-mkTransCo (Refl _) co = co
-mkTransCo co (Refl _) = co
-mkTransCo co1 co2 = TransCo co1 co2
+mkTransCo (Refl {}) co = co
+mkTransCo co (Refl {}) = co
+mkTransCo co1 co2 = TransCo co1 co2
+
+-- the Role is the desired one. It is the caller's responsibility to make
+-- sure this request is reasonable
+mkNthCoRole :: Role -> Int -> Coercion -> Coercion
+mkNthCoRole role n co
+ = maybeSubCo2 role nth_role $ nth_co
+ where
+ nth_co = mkNthCo n co
+ nth_role = coercionRole nth_co
mkNthCo :: Int -> Coercion -> Coercion
-mkNthCo n (Refl ty) = ASSERT( ok_tc_app ty n )
- Refl (tyConAppArgN n ty)
+mkNthCo n (Refl r ty) = ASSERT( ok_tc_app ty n )
+ Refl r' (tyConAppArgN n ty)
+ where tc = tyConAppTyCon ty
+ r' = nthRole r tc n
mkNthCo n co = ASSERT( ok_tc_app _ty1 n && ok_tc_app _ty2 n )
NthCo n co
where
Pair _ty1 _ty2 = coercionKind co
+
mkLRCo :: LeftOrRight -> Coercion -> Coercion
-mkLRCo lr (Refl ty) = Refl (pickLR lr (splitAppTy ty))
-mkLRCo lr co = LRCo lr co
+mkLRCo lr (Refl eq ty) = Refl eq (pickLR lr (splitAppTy ty))
+mkLRCo lr co = LRCo lr co
ok_tc_app :: Type -> Int -> Bool
ok_tc_app ty n = case splitTyConApp_maybe ty of
@@ -751,15 +965,99 @@ mkInstCo co ty = InstCo co ty
-- to implement the @unsafeCoerce#@ primitive. Optimise by pushing
-- down through type constructors.
mkUnsafeCo :: Type -> Type -> Coercion
-mkUnsafeCo ty1 ty2 | ty1 `eqType` ty2 = Refl ty1
-mkUnsafeCo (TyConApp tc1 tys1) (TyConApp tc2 tys2)
- | tc1 == tc2
- = mkTyConAppCo tc1 (zipWith mkUnsafeCo tys1 tys2)
-
-mkUnsafeCo (FunTy a1 r1) (FunTy a2 r2)
- = mkFunCo (mkUnsafeCo a1 a2) (mkUnsafeCo r1 r2)
-
-mkUnsafeCo ty1 ty2 = UnsafeCo ty1 ty2
+mkUnsafeCo = mkUnivCo Representational
+
+mkUnivCo :: Role -> Type -> Type -> Coercion
+mkUnivCo role ty1 ty2
+ | ty1 `eqType` ty2 = Refl role ty1
+ | otherwise = UnivCo role ty1 ty2
+
+-- input coercion is Nominal
+mkSubCo :: Coercion -> Coercion
+mkSubCo (Refl Nominal ty) = Refl Representational ty
+mkSubCo (TyConAppCo Nominal tc cos)
+ = TyConAppCo Representational tc (applyRoles tc cos)
+mkSubCo (UnivCo Nominal ty1 ty2) = UnivCo Representational ty1 ty2
+mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co )
+ SubCo co
+
+-- takes a Nominal coercion and possibly casts it into a Representational one
+maybeSubCo :: Role -> Coercion -> Coercion
+maybeSubCo Nominal = id
+maybeSubCo Representational = mkSubCo
+maybeSubCo Phantom = pprPanic "maybeSubCo Phantom" . ppr
+
+maybeSubCo2_maybe :: Role -- desired role
+ -> Role -- current role
+ -> Coercion -> Maybe Coercion
+maybeSubCo2_maybe Representational Nominal = Just . mkSubCo
+maybeSubCo2_maybe Nominal Representational = const Nothing
+maybeSubCo2_maybe Phantom Phantom = Just
+maybeSubCo2_maybe Phantom _ = Just . mkPhantomCo
+maybeSubCo2_maybe _ Phantom = const Nothing
+maybeSubCo2_maybe _ _ = Just
+
+maybeSubCo2 :: Role -- desired role
+ -> Role -- current role
+ -> Coercion -> Coercion
+maybeSubCo2 r1 r2 co
+ = case maybeSubCo2_maybe r1 r2 co of
+ Just co' -> co'
+ Nothing -> pprPanic "maybeSubCo2" (ppr co)
+
+-- if co is Nominal, returns it; otherwise, unwraps a SubCo; otherwise, fails
+unSubCo_maybe :: Coercion -> Maybe Coercion
+unSubCo_maybe (SubCo co) = Just co
+unSubCo_maybe (Refl _ ty) = Just $ Refl Nominal ty
+unSubCo_maybe (TyConAppCo Representational tc cos)
+ = do { cos' <- mapM unSubCo_maybe cos
+ ; return $ TyConAppCo Nominal tc cos' }
+unSubCo_maybe (UnivCo Representational ty1 ty2) = Just $ UnivCo Nominal ty1 ty2
+ -- We do *not* promote UnivCo Phantom, as that's unsafe.
+ -- UnivCo Nominal is no more unsafe than UnivCo Representational
+unSubCo_maybe co
+ | Nominal <- coercionRole co = Just co
+unSubCo_maybe _ = Nothing
+
+-- takes any coercion and turns it into a Phantom coercion
+mkPhantomCo :: Coercion -> Coercion
+mkPhantomCo co
+ | Just ty <- isReflCo_maybe co = Refl Phantom ty
+ | Pair ty1 ty2 <- coercionKind co = UnivCo Phantom ty1 ty2
+ -- don't optimise here... wait for OptCoercion
+
+-- All input coercions are assumed to be Nominal,
+-- or, if Role is Phantom, the Coercion can be Phantom, too.
+applyRole :: Role -> Coercion -> Coercion
+applyRole Nominal = id
+applyRole Representational = mkSubCo
+applyRole Phantom = mkPhantomCo
+
+-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational
+applyRoles :: TyCon -> [Coercion] -> [Coercion]
+applyRoles tc cos
+ = zipWith applyRole (tyConRolesX Representational tc) cos
+
+-- the Role parameter is the Role of the TyConAppCo
+-- defined here because this is intimiately concerned with the implementation
+-- of TyConAppCo
+tyConRolesX :: Role -> TyCon -> [Role]
+tyConRolesX Representational tc = tyConRoles tc ++ repeat Nominal
+tyConRolesX role _ = repeat role
+
+nthRole :: Role -> TyCon -> Int -> Role
+nthRole Nominal _ _ = Nominal
+nthRole Phantom _ _ = Phantom
+nthRole Representational tc n
+ = (tyConRolesX Representational tc) !! n
+
+-- is one role "less" than another?
+ltRole :: Role -> Role -> Bool
+ltRole Phantom _ = False
+ltRole Representational Phantom = True
+ltRole Representational _ = False
+ltRole Nominal Nominal = False
+ltRole Nominal _ = True
-- See note [Newtype coercions] in TyCon
@@ -768,26 +1066,29 @@ mkUnsafeCo ty1 ty2 = UnsafeCo ty1 ty2
-- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and
-- the type the appropriate right hand side of the @newtype@, with
-- the free variables a subset of those 'TyVar's.
-mkNewTypeCo :: Name -> TyCon -> [TyVar] -> Type -> CoAxiom Unbranched
-mkNewTypeCo name tycon tvs rhs_ty
+mkNewTypeCo :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched
+mkNewTypeCo name tycon tvs roles rhs_ty
= CoAxiom { co_ax_unique = nameUnique name
, co_ax_name = name
, co_ax_implicit = True -- See Note [Implicit axioms] in TyCon
+ , co_ax_role = Representational
, co_ax_tc = tycon
, co_ax_branches = FirstBranch branch }
- where branch = CoAxBranch { cab_loc = getSrcSpan name
- , cab_tvs = tvs
- , cab_lhs = mkTyVarTys tvs
- , cab_rhs = rhs_ty
+ where branch = CoAxBranch { cab_loc = getSrcSpan name
+ , cab_tvs = tvs
+ , cab_lhs = mkTyVarTys tvs
+ , cab_roles = roles
+ , cab_rhs = rhs_ty
, cab_incomps = [] }
-mkPiCos :: [Var] -> Coercion -> Coercion
-mkPiCos vs co = foldr mkPiCo co vs
+mkPiCos :: Role -> [Var] -> Coercion -> Coercion
+mkPiCos r vs co = foldr (mkPiCo r) co vs
-mkPiCo :: Var -> Coercion -> Coercion
-mkPiCo v co | isTyVar v = mkForAllCo v co
- | otherwise = mkFunCo (mkReflCo (varType v)) co
+mkPiCo :: Role -> Var -> Coercion -> Coercion
+mkPiCo r v co | isTyVar v = mkForAllCo v co
+ | otherwise = mkFunCo r (mkReflCo r (varType v)) co
+-- The first coercion *must* be Nominal.
mkCoCast :: Coercion -> Coercion -> Coercion
-- (mkCoCast (c :: s1 ~# t1) (g :: (s1 ~# t1) ~# (s2 ~# t2)
mkCoCast c g
@@ -816,7 +1117,7 @@ instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)
instNewTyCon_maybe tc tys
| Just (tvs, ty, co_tc) <- unwrapNewTyCon_maybe tc -- Check for newtype
, tys `lengthIs` tyConArity tc -- Check saturated
- = Just (substTyWith tvs tys ty, mkUnbranchedAxInstCo co_tc tys)
+ = Just (substTyWith tvs tys ty, mkUnbranchedAxInstCo Representational co_tc tys)
| otherwise
= Nothing
@@ -872,9 +1173,9 @@ coreEqCoercion co1 co2 = coreEqCoercion2 rn_env co1 co2
where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2))
coreEqCoercion2 :: RnEnv2 -> Coercion -> Coercion -> Bool
-coreEqCoercion2 env (Refl ty1) (Refl ty2) = eqTypeX env ty1 ty2
-coreEqCoercion2 env (TyConAppCo tc1 cos1) (TyConAppCo tc2 cos2)
- = tc1 == tc2 && all2 (coreEqCoercion2 env) cos1 cos2
+coreEqCoercion2 env (Refl eq1 ty1) (Refl eq2 ty2) = eq1 == eq2 && eqTypeX env ty1 ty2
+coreEqCoercion2 env (TyConAppCo eq1 tc1 cos1) (TyConAppCo eq2 tc2 cos2)
+ = eq1 == eq2 && tc1 == tc2 && all2 (coreEqCoercion2 env) cos1 cos2
coreEqCoercion2 env (AppCo co11 co12) (AppCo co21 co22)
= coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22
@@ -890,8 +1191,8 @@ coreEqCoercion2 env (AxiomInstCo con1 ind1 cos1) (AxiomInstCo con2 ind2 cos2)
&& ind1 == ind2
&& all2 (coreEqCoercion2 env) cos1 cos2
-coreEqCoercion2 env (UnsafeCo ty11 ty12) (UnsafeCo ty21 ty22)
- = eqTypeX env ty11 ty21 && eqTypeX env ty12 ty22
+coreEqCoercion2 env (UnivCo r1 ty11 ty12) (UnivCo r2 ty21 ty22)
+ = r1 == r2 && eqTypeX env ty11 ty21 && eqTypeX env ty12 ty22
coreEqCoercion2 env (SymCo co1) (SymCo co2)
= coreEqCoercion2 env co1 co2
@@ -907,6 +1208,9 @@ coreEqCoercion2 env (LRCo d1 co1) (LRCo d2 co2)
coreEqCoercion2 env (InstCo co1 ty1) (InstCo co2 ty2)
= coreEqCoercion2 env co1 co2 && eqTypeX env ty1 ty2
+coreEqCoercion2 env (SubCo co1) (SubCo co2)
+ = coreEqCoercion2 env co1 co2
+
coreEqCoercion2 _ _ _ = False
\end{code}
@@ -958,6 +1262,12 @@ extendTvSubst :: CvSubst -> TyVar -> Type -> CvSubst
extendTvSubst (CvSubst in_scope tenv cenv) tv ty
= CvSubst in_scope (extendVarEnv tenv tv ty) cenv
+extendTvSubstAndInScope :: CvSubst -> TyVar -> Type -> CvSubst
+extendTvSubstAndInScope (CvSubst in_scope tenv cenv) tv ty
+ = CvSubst (in_scope `extendInScopeSetSet` tyVarsOfType ty)
+ (extendVarEnv tenv tv ty)
+ cenv
+
extendCvSubstAndInScope :: CvSubst -> CoVar -> Coercion -> CvSubst
-- Also extends the in-scope set
extendCvSubstAndInScope (CvSubst in_scope tenv cenv) cv co
@@ -1031,25 +1341,27 @@ subst_co subst co
go_ty = Coercion.substTy subst
go :: Coercion -> Coercion
- go (Refl ty) = Refl $! go_ty ty
- go (TyConAppCo tc cos) = let args = map go cos
- in args `seqList` TyConAppCo tc args
+ go (Refl eq ty) = Refl eq $! go_ty ty
+ go (TyConAppCo eq tc cos) = let args = map go cos
+ in args `seqList` TyConAppCo eq tc args
go (AppCo co1 co2) = mkAppCo (go co1) $! go co2
go (ForAllCo tv co) = case substTyVarBndr subst tv of
(subst', tv') ->
ForAllCo tv' $! subst_co subst' co
go (CoVarCo cv) = substCoVar subst cv
go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! map go cos
- go (UnsafeCo ty1 ty2) = (UnsafeCo $! go_ty ty1) $! go_ty ty2
+ go (UnivCo r ty1 ty2) = (UnivCo r $! go_ty ty1) $! go_ty ty2
go (SymCo co) = mkSymCo (go co)
go (TransCo co1 co2) = mkTransCo (go co1) (go co2)
go (NthCo d co) = mkNthCo d (go co)
go (LRCo lr co) = mkLRCo lr (go co)
go (InstCo co ty) = mkInstCo (go co) $! go_ty ty
+ go (SubCo co) = mkSubCo (go co)
substCoVar :: CvSubst -> CoVar -> Coercion
substCoVar (CvSubst in_scope _ cenv) cv
- | Just co <- lookupVarEnv cenv cv = co
+ | Just co <- lookupVarEnv cenv cv = ASSERT2( coercionRole co == Nominal, ppr co )
+ co
| Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1
| otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv $$ ppr in_scope)
ASSERT( isCoVar cv ) CoVarCo cv
@@ -1124,47 +1436,81 @@ type LiftCoEnv = VarEnv Coercion
-- Maps *type variables* to *coercions*
-- That's the whole point of this function!
-liftCoSubstWith :: [TyVar] -> [Coercion] -> Type -> Coercion
-liftCoSubstWith tvs cos ty
- = liftCoSubst (zipEqual "liftCoSubstWith" tvs cos) ty
+liftCoSubstWith :: Role -> [TyVar] -> [Coercion] -> Type -> Coercion
+liftCoSubstWith r tvs cos ty
+ = liftCoSubst r (zipEqual "liftCoSubstWith" tvs cos) ty
-liftCoSubst :: [(TyVar,Coercion)] -> Type -> Coercion
-liftCoSubst prs ty
- | null prs = Refl ty
+liftCoSubst :: Role -> [(TyVar,Coercion)] -> Type -> Coercion
+liftCoSubst r prs ty
+ | null prs = Refl r ty
| otherwise = ty_co_subst (LCS (mkInScopeSet (tyCoVarsOfCos (map snd prs)))
- (mkVarEnv prs)) ty
+ (mkVarEnv prs)) r ty
-- | The \"lifting\" operation which substitutes coercions for type
-- variables in a type to produce a coercion.
--
-- For the inverse operation, see 'liftCoMatch'
-ty_co_subst :: LiftCoSubst -> Type -> Coercion
-ty_co_subst subst ty
- = go ty
+
+-- The Role parameter is the _desired_ role
+ty_co_subst :: LiftCoSubst -> Role -> Type -> Coercion
+ty_co_subst subst role ty
+ = go role ty
where
- go (TyVarTy tv) = liftCoSubstTyVar subst tv `orElse` Refl (TyVarTy tv)
+ go Phantom ty = lift_phantom ty
+ go role (TyVarTy tv) = liftCoSubstTyVar subst role tv
+ `orElse` Refl role (TyVarTy tv)
-- A type variable from a non-cloned forall
-- won't be in the substitution
- go (AppTy ty1 ty2) = mkAppCo (go ty1) (go ty2)
- go (TyConApp tc tys) = mkTyConAppCo tc (map go tys)
+ go role (AppTy ty1 ty2) = mkAppCo (go role ty1) (go Nominal ty2)
+ go role (TyConApp tc tys) = mkTyConAppCo role tc
+ (zipWith go (tyConRolesX role tc) tys)
-- IA0_NOTE: Do we need to do anything
-- about kind instantiations? I don't think
-- so. see Note [Kind coercions]
- go (FunTy ty1 ty2) = mkFunCo (go ty1) (go ty2)
- go (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' ty)
+ go role (FunTy ty1 ty2) = mkFunCo role (go role ty1) (go role ty2)
+ go role (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' role ty)
where
(subst', v') = liftCoSubstTyVarBndr subst v
- go ty@(LitTy {}) = mkReflCo ty
+ go role ty@(LitTy {}) = ASSERT( role == Nominal )
+ mkReflCo role ty
+
+ lift_phantom ty = mkUnivCo Phantom (liftCoSubstLeft subst ty)
+ (liftCoSubstRight subst ty)
+
+\end{code}
+
+Note [liftCoSubstTyVar]
+~~~~~~~~~~~~~~~~~~~~~~~
+This function can fail (i.e., return Nothing) for two separate reasons:
+ 1) The variable is not in the substutition
+ 2) The coercion found is of too low a role
+
+liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and
+also in matchAxiom in OptCoercion. From liftCoSubst, the so-called lifting
+lemma guarantees that the roles work out. If we fail for reason 2) in this
+case, we really should panic -- something is deeply wrong. But, in matchAxiom,
+failing for reason 2) is fine. matchAxiom is trying to find a set of coercions
+that match, but it may fail, and this is healthy behavior. Bottom line: if
+you find that liftCoSubst is doing weird things (like leaving out-of-scope
+variables lying around), disable coercion optimization (bypassing matchAxiom)
+and use maybeSubCo2 instead of maybeSubCo2_maybe. The panic will then happen,
+and you may learn something useful.
+
+\begin{code}
-liftCoSubstTyVar :: LiftCoSubst -> TyVar -> Maybe Coercion
-liftCoSubstTyVar (LCS _ cenv) tv = lookupVarEnv cenv tv
+liftCoSubstTyVar :: LiftCoSubst -> Role -> TyVar -> Maybe Coercion
+liftCoSubstTyVar (LCS _ cenv) r tv
+ = do { co <- lookupVarEnv cenv tv
+ ; let co_role = coercionRole co -- could theoretically take this as
+ -- a parameter, but painful
+ ; maybeSubCo2_maybe r co_role co } -- see Note [liftCoSubstTyVar]
liftCoSubstTyVarBndr :: LiftCoSubst -> TyVar -> (LiftCoSubst, TyVar)
liftCoSubstTyVarBndr subst@(LCS in_scope cenv) old_var
= (LCS (in_scope `extendInScopeSet` new_var) new_cenv, new_var)
where
new_cenv | no_change = delVarEnv cenv old_var
- | otherwise = extendVarEnv cenv old_var (Refl (TyVarTy new_var))
+ | otherwise = extendVarEnv cenv old_var (Refl Nominal (TyVarTy new_var))
no_change = no_kind_change && (new_var == old_var)
@@ -1175,6 +1521,16 @@ liftCoSubstTyVarBndr subst@(LCS in_scope cenv) old_var
new_var | no_kind_change = new_var1
| otherwise = setTyVarKind new_var1 (subst_kind subst old_ki)
+-- map every variable to the type on the *left* of its mapped coercion
+liftCoSubstLeft :: LiftCoSubst -> Type -> Type
+liftCoSubstLeft (LCS in_scope cenv) ty
+ = Type.substTy (mkTvSubst in_scope (mapVarEnv (pFst . coercionKind) cenv)) ty
+
+-- same, but to the type on the right
+liftCoSubstRight :: LiftCoSubst -> Type -> Type
+liftCoSubstRight (LCS in_scope cenv) ty
+ = Type.substTy (mkTvSubst in_scope (mapVarEnv (pSnd . coercionKind) cenv)) ty
+
subst_kind :: LiftCoSubst -> Kind -> Kind
-- See Note [Substituting kinds in liftCoSubst]
subst_kind subst@(LCS _ cenv) kind
@@ -1250,10 +1606,10 @@ ty_co_match menv subst (AppTy ty1 ty2) co
= do { subst' <- ty_co_match menv subst ty1 co1
; ty_co_match menv subst' ty2 co2 }
-ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo tc2 cos)
+ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos)
| tc1 == tc2 = ty_co_matches menv subst tys cos
-ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo tc cos)
+ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo _ tc cos)
| tc == funTyCon = ty_co_matches menv subst [ty1,ty2] cos
ty_co_match menv subst (ForAllTy tv1 ty) (ForAllCo tv2 co)
@@ -1269,11 +1625,14 @@ ty_co_matches :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion] -> Maybe LiftCoEn
ty_co_matches menv = matchList (ty_co_match menv)
pushRefl :: Coercion -> Maybe Coercion
-pushRefl (Refl (AppTy ty1 ty2)) = Just (AppCo (Refl ty1) (Refl ty2))
-pushRefl (Refl (FunTy ty1 ty2)) = Just (TyConAppCo funTyCon [Refl ty1, Refl ty2])
-pushRefl (Refl (TyConApp tc tys)) = Just (TyConAppCo tc (map Refl tys))
-pushRefl (Refl (ForAllTy tv ty)) = Just (ForAllCo tv (Refl ty))
-pushRefl _ = Nothing
+pushRefl (Refl Nominal (AppTy ty1 ty2))
+ = Just (AppCo (Refl Nominal ty1) (Refl Nominal ty2))
+pushRefl (Refl r (FunTy ty1 ty2))
+ = Just (TyConAppCo r funTyCon [Refl r ty1, Refl r ty2])
+pushRefl (Refl r (TyConApp tc tys))
+ = Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys))
+pushRefl (Refl r (ForAllTy tv ty)) = Just (ForAllCo tv (Refl r ty))
+pushRefl _ = Nothing
\end{code}
%************************************************************************
@@ -1284,18 +1643,19 @@ pushRefl _ = Nothing
\begin{code}
seqCo :: Coercion -> ()
-seqCo (Refl ty) = seqType ty
-seqCo (TyConAppCo tc cos) = tc `seq` seqCos cos
-seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2
-seqCo (ForAllCo tv co) = tv `seq` seqCo co
-seqCo (CoVarCo cv) = cv `seq` ()
+seqCo (Refl eq ty) = eq `seq` seqType ty
+seqCo (TyConAppCo eq tc cos) = eq `seq` tc `seq` seqCos cos
+seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2
+seqCo (ForAllCo tv co) = tv `seq` seqCo co
+seqCo (CoVarCo cv) = cv `seq` ()
seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos
-seqCo (UnsafeCo ty1 ty2) = seqType ty1 `seq` seqType ty2
-seqCo (SymCo co) = seqCo co
-seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2
-seqCo (NthCo _ co) = seqCo co
-seqCo (LRCo _ co) = seqCo co
-seqCo (InstCo co ty) = seqCo co `seq` seqType ty
+seqCo (UnivCo r ty1 ty2) = r `seq` seqType ty1 `seq` seqType ty2
+seqCo (SymCo co) = seqCo co
+seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2
+seqCo (NthCo _ co) = seqCo co
+seqCo (LRCo _ co) = seqCo co
+seqCo (InstCo co ty) = seqCo co `seq` seqType ty
+seqCo (SubCo co) = seqCo co
seqCos :: [Coercion] -> ()
seqCos [] = ()
@@ -1312,7 +1672,7 @@ seqCos (co:cos) = seqCo co `seq` seqCos cos
\begin{code}
coercionType :: Coercion -> Type
coercionType co = case coercionKind co of
- Pair ty1 ty2 -> mkCoercionType ty1 ty2
+ Pair ty1 ty2 -> mkCoercionType (coercionRole co) ty1 ty2
------------------
-- | If it is the case that
@@ -1324,11 +1684,11 @@ coercionType co = case coercionKind co of
coercionKind :: Coercion -> Pair Type
coercionKind co = go co
where
- go (Refl ty) = Pair ty ty
- go (TyConAppCo tc cos) = mkTyConApp tc <$> (sequenceA $ map go cos)
- go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2
- go (ForAllCo tv co) = mkForAllTy tv <$> go co
- go (CoVarCo cv) = toPair $ coVarKind cv
+ go (Refl _ ty) = Pair ty ty
+ go (TyConAppCo _ tc cos) = mkTyConApp tc <$> (sequenceA $ map go cos)
+ go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2
+ go (ForAllCo tv co) = mkForAllTy tv <$> go co
+ go (CoVarCo cv) = toPair $ coVarKind cv
go (AxiomInstCo ax ind cos)
| CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind
, Pair tys1 tys2 <- sequenceA (map go cos)
@@ -1336,12 +1696,13 @@ coercionKind co = go co
-- exactly saturate the axiom branch
Pair (substTyWith tvs tys1 (mkTyConApp (coAxiomTyCon ax) lhs))
(substTyWith tvs tys2 rhs)
- go (UnsafeCo ty1 ty2) = Pair ty1 ty2
- go (SymCo co) = swap $ go co
- go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2)
- go (NthCo d co) = tyConAppArgN d <$> go co
- go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co
- go (InstCo aco ty) = go_app aco [ty]
+ go (UnivCo _ ty1 ty2) = Pair ty1 ty2
+ go (SymCo co) = swap $ go co
+ go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2)
+ go (NthCo d co) = tyConAppArgN d <$> go co
+ go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co
+ go (InstCo aco ty) = go_app aco [ty]
+ go (SubCo co) = go co
go_app :: Coercion -> [Type] -> Pair Type
-- Collect up all the arguments and apply all at once
@@ -1352,6 +1713,25 @@ coercionKind co = go co
-- | Apply 'coercionKind' to multiple 'Coercion's
coercionKinds :: [Coercion] -> Pair [Type]
coercionKinds tys = sequenceA $ map coercionKind tys
+
+coercionRole :: Coercion -> Role
+coercionRole = go
+ where
+ go (Refl r _) = r
+ go (TyConAppCo r _ _) = r
+ go (AppCo co _) = go co
+ go (ForAllCo _ co) = go co
+ go (CoVarCo cv) = coVarRole cv
+ go (AxiomInstCo ax _ _) = coAxiomRole ax
+ go (UnivCo r _ _) = r
+ go (SymCo co) = go co
+ go (TransCo co1 _) = go co1 -- same as go co2
+ go (NthCo n co) = let Pair ty1 _ = coercionKind co
+ (tc, _) = splitTyConApp ty1
+ in nthRole (coercionRole co) tc n
+ go (LRCo _ _) = Nominal
+ go (InstCo co _) = go co
+ go (SubCo _) = Representational
\end{code}
Note [Nested InstCos]
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 63a4c50e2c..b6fdb35dc7 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -499,16 +499,18 @@ We print out axioms and don't want to print stuff like
Instead we must tidy those kind variables. See Trac #7524.
\begin{code}
+-- all axiom roles are Nominal, as this is only used with type families
mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars
-> [Type] -- LHS patterns
-> Type -- RHS
-> SrcSpan
-> CoAxBranch
mkCoAxBranch tvs lhs rhs loc
- = CoAxBranch { cab_tvs = tvs1
- , cab_lhs = tidyTypes env lhs
- , cab_rhs = tidyType env rhs
- , cab_loc = loc
+ = CoAxBranch { cab_tvs = tvs1
+ , cab_lhs = tidyTypes env lhs
+ , cab_roles = map (const Nominal) tvs1
+ , cab_rhs = tidyType env rhs
+ , cab_loc = loc
, cab_incomps = placeHolderIncomps }
where
(env, tvs1) = tidyTyVarBndrs emptyTidyEnv tvs
@@ -522,6 +524,7 @@ mkBranchedCoAxiom ax_name fam_tc branches
CoAxiom { co_ax_unique = nameUnique ax_name
, co_ax_name = ax_name
, co_ax_tc = fam_tc
+ , co_ax_role = Nominal
, co_ax_implicit = False
, co_ax_branches = toBranchList branches }
@@ -530,6 +533,7 @@ mkUnbranchedCoAxiom ax_name fam_tc branch
= CoAxiom { co_ax_unique = nameUnique ax_name
, co_ax_name = ax_name
, co_ax_tc = fam_tc
+ , co_ax_role = Nominal
, co_ax_implicit = False
, co_ax_branches = FirstBranch (branch { cab_incomps = [] }) }
@@ -538,6 +542,7 @@ mkSingleCoAxiom ax_name tvs fam_tc lhs_tys rhs_ty
= CoAxiom { co_ax_unique = nameUnique ax_name
, co_ax_name = ax_name
, co_ax_tc = fam_tc
+ , co_ax_role = Nominal
, co_ax_implicit = False
, co_ax_branches = FirstBranch (branch { cab_incomps = [] }) }
where
@@ -764,19 +769,20 @@ but we also need to handle closed ones when normalising a type:
\begin{code}
-- The TyCon can be oversaturated. This works on both open and closed families
-chooseAxiom :: FamInstEnvs -> TyCon -> [Type] -> Maybe (Coercion, Type)
-chooseAxiom envs tc tys
+chooseAxiom :: FamInstEnvs -> Role -> TyCon -> [Type] -> Maybe (Coercion, Type)
+chooseAxiom envs role tc tys
| isOpenFamilyTyCon tc
, [FamInstMatch { fim_instance = fam_inst
, fim_tys = inst_tys }] <- lookupFamInstEnv envs tc tys
- = let co = mkUnbranchedAxInstCo (famInstAxiom fam_inst) inst_tys
- ty = pSnd (coercionKind co)
+ = let ax = famInstAxiom fam_inst
+ co = mkUnbranchedAxInstCo role ax inst_tys
+ ty = pSnd (coercionKind co)
in Just (co, ty)
| Just ax <- isClosedSynFamilyTyCon_maybe tc
, Just (ind, inst_tys) <- chooseBranch ax tys
- = let co = mkAxInstCo ax ind inst_tys
- ty = pSnd (coercionKind co)
+ = let co = mkAxInstCo role ax ind inst_tys
+ ty = pSnd (coercionKind co)
in Just (co, ty)
| otherwise
@@ -843,6 +849,7 @@ topNormaliseType :: FamInstEnvs
-- (F ty) is a redex.
-- Its a bit like Type.repType, but handles type families too
+-- The coercion returned is always an R coercion
topNormaliseType env ty
= go initRecTc ty
@@ -857,7 +864,7 @@ topNormaliseType env ty
go rec_nts (TyConApp tc tys)
| isFamilyTyCon tc -- Expand family tycons
- , (co, ty) <- normaliseTcApp env tc tys
+ , (co, ty) <- normaliseTcApp env Representational tc tys
-- Note that normaliseType fully normalises 'tys',
-- wrt type functions but *not* newtypes
-- It has do to so to be sure that nested calls like
@@ -875,13 +882,13 @@ topNormaliseType env ty
---------------
-normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (Coercion, Type)
-normaliseTcApp env tc tys
+normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type)
+normaliseTcApp env role tc tys
| isFamilyTyCon tc
- , Just (co, rhs) <- chooseAxiom env tc ntys
+ , Just (co, rhs) <- chooseAxiom env role tc ntys
= let -- A reduction is possible
first_coi = mkTransCo tycon_coi co
- (rest_coi,nty) = normaliseType env rhs
+ (rest_coi,nty) = normaliseType env role rhs
fix_coi = mkTransCo first_coi rest_coi
in
(fix_coi, nty)
@@ -893,35 +900,36 @@ normaliseTcApp env tc tys
where
-- Normalise the arg types so that they'll match
-- when we lookup in in the instance envt
- (cois, ntys) = mapAndUnzip (normaliseType env) tys
- tycon_coi = mkTyConAppCo tc cois
+ (cois, ntys) = zipWithAndUnzip (normaliseType env) (tyConRolesX role tc) tys
+ tycon_coi = mkTyConAppCo role tc cois
---------------
normaliseType :: FamInstEnvs -- environment with family instances
- -> Type -- old type
+ -> Role -- desired role of output coercion
+ -> Type -- old type
-> (Coercion, Type) -- (coercion,new type), where
-- co :: old-type ~ new_type
-- Normalise the input type, by eliminating *all* type-function redexes
-- Returns with Refl if nothing happens
-normaliseType env ty
- | Just ty' <- coreView ty = normaliseType env ty'
-normaliseType env (TyConApp tc tys)
- = normaliseTcApp env tc tys
-normaliseType _env ty@(LitTy {}) = (Refl ty, ty)
-normaliseType env (AppTy ty1 ty2)
- = let (coi1,nty1) = normaliseType env ty1
- (coi2,nty2) = normaliseType env ty2
+normaliseType env role ty
+ | Just ty' <- coreView ty = normaliseType env role ty'
+normaliseType env role (TyConApp tc tys)
+ = normaliseTcApp env role tc tys
+normaliseType _env role ty@(LitTy {}) = (Refl role ty, ty)
+normaliseType env role (AppTy ty1 ty2)
+ = let (coi1,nty1) = normaliseType env role ty1
+ (coi2,nty2) = normaliseType env Nominal ty2
in (mkAppCo coi1 coi2, mkAppTy nty1 nty2)
-normaliseType env (FunTy ty1 ty2)
- = let (coi1,nty1) = normaliseType env ty1
- (coi2,nty2) = normaliseType env ty2
- in (mkFunCo coi1 coi2, mkFunTy nty1 nty2)
-normaliseType env (ForAllTy tyvar ty1)
- = let (coi,nty1) = normaliseType env ty1
+normaliseType env role (FunTy ty1 ty2)
+ = let (coi1,nty1) = normaliseType env role ty1
+ (coi2,nty2) = normaliseType env role ty2
+ in (mkFunCo role coi1 coi2, mkFunTy nty1 nty2)
+normaliseType env role (ForAllTy tyvar ty1)
+ = let (coi,nty1) = normaliseType env role ty1
in (mkForAllCo tyvar coi, ForAllTy tyvar nty1)
-normaliseType _ ty@(TyVarTy _)
- = (Refl ty,ty)
+normaliseType _ role ty@(TyVarTy _)
+ = (Refl role ty,ty)
\end{code}
%************************************************************************
@@ -1024,4 +1032,4 @@ allTyVarsInTy = go
(go ty) -- don't remove tv
go (LitTy {}) = emptyVarSet
-\end{code} \ No newline at end of file
+\end{code}
diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs
index 03175f33f9..9f965ece26 100644
--- a/compiler/types/OptCoercion.lhs
+++ b/compiler/types/OptCoercion.lhs
@@ -26,10 +26,11 @@ import VarEnv
import StaticFlags ( opt_NoOptCoercion )
import Outputable
import Pair
-import Maybes( allMaybes )
+import Maybes
import FastString
import Util
import Unify
+import ListSetOps
import InstEnv
\end{code}
@@ -62,7 +63,7 @@ optCoercion :: CvSubst -> Coercion -> NormalCo
-- *and* optimises it to reduce its size
optCoercion env co
| opt_NoOptCoercion = substCo env co
- | otherwise = opt_co env False co
+ | otherwise = opt_co env False Nothing co
type NormalCo = Coercion
-- Invariants:
@@ -75,9 +76,11 @@ type NormalNonIdCo = NormalCo -- Extra invariant: not the identity
opt_co, opt_co' :: CvSubst
-> Bool -- True <=> return (sym co)
+ -> Maybe Role -- Nothing <=> don't change; otherwise, change
+ -- INVARIANT: the change is always a *downgrade*
-> Coercion
-> NormalCo
-opt_co = opt_co'
+opt_co = opt_co'
{-
opt_co env sym co
= pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $
@@ -103,73 +106,111 @@ opt_co env sym co
| otherwise = substCo env co
-}
-opt_co' env _ (Refl ty) = Refl (substTy env ty)
-opt_co' env sym (SymCo co) = opt_co env (not sym) co
-opt_co' env sym (TyConAppCo tc cos) = mkTyConAppCo tc (map (opt_co env sym) cos)
-opt_co' env sym (AppCo co1 co2) = mkAppCo (opt_co env sym co1) (opt_co env sym co2)
-opt_co' env sym (ForAllCo tv co) = case substTyVarBndr env tv of
- (env', tv') -> mkForAllCo tv' (opt_co env' sym co)
+opt_co' env _ mrole (Refl r ty) = Refl (mrole `orElse` r) (substTy env ty)
+opt_co' env sym mrole co
+ | mrole == Just Phantom
+ || coercionRole co == Phantom
+ , Pair ty1 ty2 <- coercionKind co
+ = if sym
+ then opt_univ env Phantom ty2 ty1
+ else opt_univ env Phantom ty1 ty2
+
+opt_co' env sym mrole (SymCo co) = opt_co env (not sym) mrole co
+opt_co' env sym mrole (TyConAppCo r tc cos)
+ = case mrole of
+ Nothing -> mkTyConAppCo r tc (map (opt_co env sym Nothing) cos)
+ Just r' -> mkTyConAppCo r' tc (zipWith (opt_co env sym)
+ (map Just (tyConRolesX r' tc)) cos)
+opt_co' env sym mrole (AppCo co1 co2) = mkAppCo (opt_co env sym mrole co1)
+ (opt_co env sym Nothing co2)
+opt_co' env sym mrole (ForAllCo tv co)
+ = case substTyVarBndr env tv of
+ (env', tv') -> mkForAllCo tv' (opt_co env' sym mrole co)
-- Use the "mk" functions to check for nested Refls
-opt_co' env sym (CoVarCo cv)
+opt_co' env sym mrole (CoVarCo cv)
| Just co <- lookupCoVar env cv
- = opt_co (zapCvSubstEnv env) sym co
+ = opt_co (zapCvSubstEnv env) sym mrole co
| Just cv1 <- lookupInScope (getCvInScope env) cv
- = ASSERT( isCoVar cv1 ) wrapSym sym (CoVarCo cv1)
+ = ASSERT( isCoVar cv1 ) wrapRole mrole cv_role $ wrapSym sym (CoVarCo cv1)
-- cv1 might have a substituted kind!
| otherwise = WARN( True, ptext (sLit "opt_co: not in scope:") <+> ppr cv $$ ppr env)
ASSERT( isCoVar cv )
- wrapSym sym (CoVarCo cv)
+ wrapRole mrole cv_role $ wrapSym sym (CoVarCo cv)
+ where cv_role = coVarRole cv
-opt_co' env sym (AxiomInstCo con ind cos)
+opt_co' env sym mrole (AxiomInstCo con ind cos)
-- Do *not* push sym inside top-level axioms
-- e.g. if g is a top-level axiom
-- g a : f a ~ a
-- then (sym (g ty)) /= g (sym ty) !!
- = wrapSym sym $ AxiomInstCo con ind (map (opt_co env False) cos)
+ = wrapRole mrole (coAxiomRole con) $
+ wrapSym sym $
+ AxiomInstCo con ind (map (opt_co env False Nothing) cos)
-- Note that the_co does *not* have sym pushed into it
-opt_co' env sym (UnsafeCo ty1 ty2)
- | ty1' `eqType` ty2' = Refl ty1'
- | sym = mkUnsafeCo ty2' ty1'
- | otherwise = mkUnsafeCo ty1' ty2'
+opt_co' env sym mrole (UnivCo r oty1 oty2)
+ = opt_univ env role a b
where
- ty1' = substTy env ty1
- ty2' = substTy env ty2
+ (a,b) = if sym then (oty2,oty1) else (oty1,oty2)
+ role = mrole `orElse` r
-opt_co' env sym (TransCo co1 co2)
+opt_co' env sym mrole (TransCo co1 co2)
| sym = opt_trans in_scope opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g
| otherwise = opt_trans in_scope opt_co1 opt_co2
where
- opt_co1 = opt_co env sym co1
- opt_co2 = opt_co env sym co2
+ opt_co1 = opt_co env sym mrole co1
+ opt_co2 = opt_co env sym mrole co2
in_scope = getCvInScope env
-opt_co' env sym (NthCo n co)
- | TyConAppCo tc cos <- co'
+-- NthCo roles are fiddly!
+opt_co' env sym mrole (NthCo n (TyConAppCo _ _ cos))
+ = opt_co env sym mrole (getNth cos n)
+opt_co' env sym mrole (NthCo n co)
+ | TyConAppCo _ _tc cos <- co'
, isDecomposableTyCon tc -- Not synonym families
= ASSERT( n < length cos )
- cos !! n
+ ASSERT( _tc == tc )
+ let resultCo = cos !! n
+ resultRole = coercionRole resultCo in
+ case (mrole, resultRole) of
+ -- if we just need an R coercion, try to propagate the SubCo again:
+ (Just Representational, Nominal) -> opt_co (zapCvSubstEnv env) False mrole resultCo
+ _ -> resultCo
+
| otherwise
- = NthCo n co'
- where
- co' = opt_co env sym co
+ = wrap_role $ NthCo n co'
-opt_co' env sym (LRCo lr co)
+ where
+ wrap_role wrapped = wrapRole mrole (coercionRole wrapped) wrapped
+
+ tc = tyConAppTyCon $ pFst $ coercionKind co
+ co' = opt_co env sym mrole' co
+ mrole' = case mrole of
+ Just Representational
+ | Representational <- nthRole Representational tc n
+ -> Just Representational
+ _ -> Nothing
+
+opt_co' env sym mrole (LRCo lr co)
+ | Just pr_co <- splitAppCo_maybe co
+ = opt_co env sym mrole (pickLR lr pr_co)
| Just pr_co <- splitAppCo_maybe co'
- = pickLR lr pr_co
+ = if mrole == Just Representational
+ then opt_co (zapCvSubstEnv env) False mrole (pickLR lr pr_co)
+ else pickLR lr pr_co
| otherwise
- = LRCo lr co'
+ = wrapRole mrole Nominal $ LRCo lr co'
where
- co' = opt_co env sym co
+ co' = opt_co env sym Nothing co
-opt_co' env sym (InstCo co ty)
+opt_co' env sym mrole (InstCo co ty)
-- See if the first arg is already a forall
-- ...then we can just extend the current substitution
| Just (tv, co_body) <- splitForAllCo_maybe co
- = opt_co (extendTvSubst env tv ty') sym co_body
+ = opt_co (extendTvSubst env tv ty') sym mrole co_body
-- See if it is a forall after optimization
-- If so, do an inefficient one-variable substitution
@@ -178,9 +219,37 @@ opt_co' env sym (InstCo co ty)
| otherwise = InstCo co' ty'
where
- co' = opt_co env sym co
+ co' = opt_co env sym mrole co
ty' = substTy env ty
+opt_co' env sym _ (SubCo co) = opt_co env sym (Just Representational) co
+
+-------------
+opt_univ :: CvSubst -> Role -> Type -> Type -> Coercion
+opt_univ env role oty1 oty2
+ | Just (tc1, tys1) <- splitTyConApp_maybe oty1
+ , Just (tc2, tys2) <- splitTyConApp_maybe oty2
+ , tc1 == tc2
+ = mkTyConAppCo role tc1 (zipWith3 (opt_univ env) (tyConRolesX role tc1) tys1 tys2)
+
+ | Just (l1, r1) <- splitAppTy_maybe oty1
+ , Just (l2, r2) <- splitAppTy_maybe oty2
+ , typeKind l1 `eqType` typeKind l2 -- kind(r1) == kind(r2) by consequence
+ = let role' = if role == Phantom then Phantom else Nominal in
+ -- role' is to comform to mkAppCo's precondition
+ mkAppCo (opt_univ env role l1 l2) (opt_univ env role' r1 r2)
+
+ | Just (tv1, ty1) <- splitForAllTy_maybe oty1
+ , Just (tv2, ty2) <- splitForAllTy_maybe oty2
+ , tyVarKind tv1 `eqType` tyVarKind tv2 -- rule out a weird unsafeCo
+ = case substTyVarBndr2 env tv1 tv2 of { (env1, env2, tv') ->
+ let ty1' = substTy env1 ty1
+ ty2' = substTy env2 ty2 in
+ mkForAllCo tv' (opt_univ (zapCvSubstEnv2 env1 env2) role ty1' ty2') }
+
+ | otherwise
+ = mkUnivCo role (substTy env oty1) (substTy env oty2)
+
-------------
opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
opt_transList is = zipWith (opt_trans is)
@@ -240,27 +309,28 @@ opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)
mkInstCo (opt_trans is co1 co2) ty1
-- Push transitivity down through matching top-level constructors.
-opt_trans_rule is in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2)
+opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2)
| tc1 == tc2
- = fireTransRule "PushTyConApp" in_co1 in_co2 $
- TyConAppCo tc1 (opt_transList is cos1 cos2)
+ = ASSERT( r1 == r2 )
+ fireTransRule "PushTyConApp" in_co1 in_co2 $
+ TyConAppCo r1 tc1 (opt_transList is cos1 cos2)
opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
= fireTransRule "TrPushApp" in_co1 in_co2 $
mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b)
-- Eta rules
-opt_trans_rule is co1@(TyConAppCo tc cos1) co2
+opt_trans_rule is co1@(TyConAppCo r tc cos1) co2
| Just cos2 <- etaTyConAppCo_maybe tc co2
= ASSERT( length cos1 == length cos2 )
fireTransRule "EtaCompL" co1 co2 $
- TyConAppCo tc (opt_transList is cos1 cos2)
+ TyConAppCo r tc (opt_transList is cos1 cos2)
-opt_trans_rule is co1 co2@(TyConAppCo tc cos2)
+opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)
| Just cos1 <- etaTyConAppCo_maybe tc co1
= ASSERT( length cos1 == length cos2 )
fireTransRule "EtaCompR" co1 co2 $
- TyConAppCo tc (opt_transList is cos1 cos2)
+ TyConAppCo r tc (opt_transList is cos1 cos2)
opt_trans_rule is co1@(AppCo co1a co1b) co2
| Just (co2a,co2b) <- etaAppCo_maybe co2
@@ -337,18 +407,19 @@ opt_trans_rule is co1 co2
, all (`elemVarSet` pivot_tvs) qtvs
= fireTransRule "TrPushAxSym" co1 co2 $
if sym2
- then liftCoSubstWith qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym
- else liftCoSubstWith qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs -- TrPushSymAx
+ then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym
+ else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs -- TrPushSymAx
where
co1_is_axiom_maybe = isAxiom_maybe co1
co2_is_axiom_maybe = isAxiom_maybe co2
+ role = coercionRole co1 -- should be the same as coercionRole co2!
opt_trans_rule _ co1 co2 -- Identity rule
| Pair ty1 _ <- coercionKind co1
, Pair _ ty2 <- coercionKind co2
, ty1 `eqType` ty2
= fireTransRule "RedTypeDirRefl" co1 co2 $
- Refl ty2
+ Refl (coercionRole co1) ty2
opt_trans_rule _ _ _ = Nothing
@@ -415,6 +486,24 @@ wrapSym :: Bool -> Coercion -> Coercion
wrapSym sym co | sym = SymCo co
| otherwise = co
+wrapRole :: Maybe Role -- desired
+ -> Role -- current
+ -> Coercion -> Coercion
+wrapRole Nothing _ = id
+wrapRole (Just desired) current = maybeSubCo2 desired current
+
+-----------
+-- takes two tyvars and builds env'ts to map them to the same tyvar
+substTyVarBndr2 :: CvSubst -> TyVar -> TyVar
+ -> (CvSubst, CvSubst, TyVar)
+substTyVarBndr2 env tv1 tv2
+ = case substTyVarBndr env tv1 of
+ (env1, tv1') -> (env1, extendTvSubstAndInScope env tv2 (mkTyVarTy tv1'), tv1')
+
+zapCvSubstEnv2 :: CvSubst -> CvSubst -> CvSubst
+zapCvSubstEnv2 env1 env2 = mkCvSubst (is1 `unionInScope` is2) []
+ where is1 = getCvInScope env1
+ is2 = getCvInScope env2
-----------
isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion])
isAxiom_maybe (SymCo co)
@@ -429,12 +518,13 @@ matchAxiom :: Bool -- True = match LHS, False = match RHS
-- If we succeed in matching, then *all the quantified type variables are bound*
-- E.g. if tvs = [a,b], lhs/rhs = [b], we'll fail
matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co
- = let (CoAxBranch { cab_tvs = qtvs
- , cab_lhs = lhs
- , cab_rhs = rhs }) = coAxiomNthBranch ax ind in
+ = let (CoAxBranch { cab_tvs = qtvs
+ , cab_roles = roles
+ , cab_lhs = lhs
+ , cab_rhs = rhs }) = coAxiomNthBranch ax ind in
case liftCoMatch (mkVarSet qtvs) (if sym then (mkTyConApp tc lhs) else rhs) co of
Nothing -> Nothing
- Just subst -> allMaybes (map (liftCoSubstTyVar subst) qtvs)
+ Just subst -> allMaybes (zipWith (liftCoSubstTyVar subst) roles qtvs)
-------------
compatible_co :: Coercion -> Coercion -> Bool
@@ -468,7 +558,8 @@ etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion)
etaAppCo_maybe co
| Just (co1,co2) <- splitAppCo_maybe co
= Just (co1,co2)
- | Pair ty1 ty2 <- coercionKind co
+ | Nominal <- coercionRole co
+ , Pair ty1 ty2 <- coercionKind co
, Just (_,t1) <- splitAppTy_maybe ty1
, Just (_,t2) <- splitAppTy_maybe ty2
, typeKind t1 `eqType` typeKind t2 -- Note [Eta for AppCo]
@@ -480,7 +571,7 @@ etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]
-- If possible, split a coercion
-- g :: T s1 .. sn ~ T t1 .. tn
-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ]
-etaTyConAppCo_maybe tc (TyConAppCo tc2 cos2)
+etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)
= ASSERT( tc == tc2 ) Just cos2
etaTyConAppCo_maybe tc co
@@ -492,7 +583,7 @@ etaTyConAppCo_maybe tc co
, let n = length tys1
= ASSERT( tc == tc1 )
ASSERT( n == length tys2 )
- Just (decomposeCo n co)
+ Just (decomposeCo n co)
-- NB: n might be <> tyConArity tc
-- e.g. data family T a :: * -> *
-- g :: T a b ~ T c d
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index fb078ec979..8a699614c6 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -13,7 +13,7 @@ module TyCon(
AlgTyConRhs(..), visibleDataCons,
TyConParent(..), isNoParent,
- SynTyConRhs(..),
+ SynTyConRhs(..), Role(..),
-- ** Constructing TyCons
mkAlgTyCon,
@@ -65,6 +65,7 @@ module TyCon(
tyConFamilySize,
tyConStupidTheta,
tyConArity,
+ tyConRoles,
tyConParent,
tyConTuple_maybe, tyConClass_maybe,
tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe,
@@ -271,6 +272,28 @@ This is important. In an instance declaration we expect
data T p [x] = T1 x | T2 p
type F [x] q (Tree y) = (x,y,q)
+Note [TyCon Role signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Every tycon has a role signature, assigning a role to each of the tyConTyVars
+(or of equal length to the tyConArity, if there are no tyConTyVars). An
+example demonstrates these best: say we have a tycon T, with parameters a@N,
+b@R, and c@P. Then, to prove representational equality between T a1 b1 c1 and
+T a2 b2 c2, we need to have nominal equality between a1 and a2, representational
+equality between b1 and b2, and nothing in particular (i.e., phantom equality)
+between c1 and c2. This might happen, say, with the following declaration:
+
+ data T a b c where
+ MkT :: b -> T Int b c
+
+Data and class tycons have their roles inferred (see inferRoles in TcTyDecls),
+as do vanilla synonym tycons. Family tycons have all parameters at role N,
+though it is conceivable that we could relax this restriction. (->)'s and
+tuples' parameters are at role R. Each primitive tycon declares its roles;
+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.
+
%************************************************************************
%* *
\subsection{The data type}
@@ -321,6 +344,10 @@ data TyCon
-- 3. The family instance types if present
--
-- Note that it does /not/ scope over the data constructors.
+ tc_roles :: [Role], -- ^ The role for each type variable
+ -- This list has the same length as tyConTyVars
+ -- See also Note [TyCon Role signatures]
+
tyConCType :: Maybe CType, -- The C type that should be used
-- for this type when using the FFI
-- and CAPI
@@ -372,6 +399,7 @@ data TyCon
tyConArity :: Arity,
tyConTyVars :: [TyVar], -- Bound tyvars
+ tc_roles :: [Role],
synTcRhs :: SynTyConRhs, -- ^ Contains information about the
-- expansion of the synonym
@@ -388,8 +416,8 @@ data TyCon
tyConUnique :: Unique,
tyConName :: Name,
tc_kind :: Kind,
- tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance
- -- of the arity of a primtycon is!
+ tyConArity :: Arity,
+ tc_roles :: [Role],
primTyConRep :: PrimRep, -- ^ Many primitive tycons are unboxed, but some are
-- boxed (represented by pointers). This 'PrimRep'
@@ -409,6 +437,7 @@ data TyCon
tyConUnique :: Unique, -- ^ Same Unique as the data constructor
tyConName :: Name, -- ^ Same Name as the data constructor
tyConArity :: Arity,
+ tc_roles :: [Role], -- ^ Roles: N for kind vars, R for type vars
tc_kind :: Kind, -- ^ Translated type of the data constructor
dataCon :: DataCon -- ^ Corresponding data constructor
}
@@ -496,6 +525,7 @@ data AlgTyConRhs
-- Watch out! If any newtypes become transparent
-- again check Trac #1072.
}
+
\end{code}
Note [AbstractTyCon and type equality]
@@ -683,10 +713,12 @@ which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s])
Note [Newtype eta]
~~~~~~~~~~~~~~~~~~
Consider
- newtype Parser m a = MkParser (Foogle m a)
+ newtype Parser a = MkParser (IO a) derriving( Monad )
Are these two types equal (to Core)?
- Monad (Parser m)
- Monad (Foogle m)
+ Monad Parser
+ Monad IO
+which we need to make the derived instance for Monad Parser.
+
Well, yes. But to see that easily we eta-reduce the RHS type of
Parser, in this case to ([], Froogle), so that even unsaturated applications
of Parser will work right. This eta reduction is done when the type
@@ -875,6 +907,7 @@ mkAlgTyCon :: Name
-> Kind -- ^ Kind of the resulting 'TyCon'
-> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'.
-- Arity is inferred from the length of this list
+ -> [Role] -- ^ The roles for each TyVar
-> Maybe CType -- ^ The C type this type corresponds to
-- when using the CAPI FFI
-> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta'
@@ -884,13 +917,14 @@ mkAlgTyCon :: Name
-> Bool -- ^ Was the 'TyCon' declared with GADT syntax?
-> Maybe TyCon -- ^ Promoted version
-> TyCon
-mkAlgTyCon name kind tyvars cType stupid rhs parent is_rec gadt_syn prom_tc
+mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_tc
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tc_kind = kind,
tyConArity = length tyvars,
tyConTyVars = tyvars,
+ tc_roles = roles,
tyConCType = cType,
algTcStupidTheta = stupid,
algTcRhs = rhs,
@@ -901,9 +935,9 @@ mkAlgTyCon name kind tyvars cType stupid rhs parent is_rec gadt_syn prom_tc
}
-- | Simpler specialization of 'mkAlgTyCon' for classes
-mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon
-mkClassTyCon name kind tyvars rhs clas is_rec
- = mkAlgTyCon name kind tyvars Nothing [] rhs (ClassTyCon clas)
+mkClassTyCon :: Name -> Kind -> [TyVar] -> [Role] -> AlgTyConRhs -> Class -> RecFlag -> TyCon
+mkClassTyCon name kind tyvars roles rhs clas is_rec
+ = mkAlgTyCon name kind tyvars roles Nothing [] rhs (ClassTyCon clas)
is_rec False
Nothing -- Class TyCons are not pormoted
@@ -934,14 +968,14 @@ mkTupleTyCon name kind arity tyvars con sort prom_tc
mkForeignTyCon :: Name
-> Maybe FastString -- ^ Name of the foreign imported thing, maybe
-> Kind
- -> Arity
-> TyCon
-mkForeignTyCon name ext_name kind arity
+mkForeignTyCon name ext_name kind
= PrimTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tc_kind = kind,
- tyConArity = arity,
+ tyConArity = 0,
+ tc_roles = [],
primTyConRep = PtrRep, -- they all do
isUnLifted = False,
tyConExtName = ext_name
@@ -949,41 +983,43 @@ mkForeignTyCon name ext_name kind arity
-- | Create an unlifted primitive 'TyCon', such as @Int#@
-mkPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon
-mkPrimTyCon name kind arity rep
- = mkPrimTyCon' name kind arity rep True
+mkPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon
+mkPrimTyCon name kind roles rep
+ = mkPrimTyCon' name kind roles rep True
-- | Kind constructors
mkKindTyCon :: Name -> Kind -> TyCon
mkKindTyCon name kind
- = mkPrimTyCon' name kind 0 VoidRep True
+ = mkPrimTyCon' name kind [] VoidRep True
-- | Create a lifted primitive 'TyCon' such as @RealWorld@
-mkLiftedPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon
-mkLiftedPrimTyCon name kind arity rep
- = mkPrimTyCon' name kind arity rep False
+mkLiftedPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon
+mkLiftedPrimTyCon name kind roles rep
+ = mkPrimTyCon' name kind roles rep False
-mkPrimTyCon' :: Name -> Kind -> Arity -> PrimRep -> Bool -> TyCon
-mkPrimTyCon' name kind arity rep is_unlifted
+mkPrimTyCon' :: Name -> Kind -> [Role] -> PrimRep -> Bool -> TyCon
+mkPrimTyCon' name kind roles rep is_unlifted
= PrimTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tc_kind = kind,
- tyConArity = arity,
+ tyConArity = length roles,
+ tc_roles = roles,
primTyConRep = rep,
isUnLifted = is_unlifted,
tyConExtName = Nothing
}
-- | Create a type synonym 'TyCon'
-mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs -> TyConParent -> TyCon
-mkSynTyCon name kind tyvars rhs parent
+mkSynTyCon :: Name -> Kind -> [TyVar] -> [Role] -> SynTyConRhs -> TyConParent -> TyCon
+mkSynTyCon name kind tyvars roles rhs parent
= SynTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tc_kind = kind,
tyConArity = length tyvars,
tyConTyVars = tyvars,
+ tc_roles = roles,
synTcRhs = rhs,
synTcParent = parent
}
@@ -992,15 +1028,18 @@ mkSynTyCon name kind tyvars rhs parent
-- 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 -> Unique -> Kind -> Arity -> TyCon
-mkPromotedDataCon con name unique kind arity
+mkPromotedDataCon :: DataCon -> Name -> Unique -> Kind -> [Role] -> TyCon
+mkPromotedDataCon con name unique kind roles
= PromotedDataCon {
tyConName = name,
tyConUnique = unique,
tyConArity = arity,
+ tc_roles = roles,
tc_kind = kind,
dataCon = con
}
+ where
+ arity = length roles
-- | Create a promoted type constructor 'TyCon'
-- Somewhat dodgily, we give it the same Name
@@ -1396,6 +1435,23 @@ algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs
algTyConRhs (TupleTyCon {dataCon = con, tyConArity = arity})
= DataTyCon { data_cons = [con], is_enum = arity == 0 }
algTyConRhs other = pprPanic "algTyConRhs" (ppr other)
+
+-- | Get the list of roles for the type parameters of a TyCon
+tyConRoles :: TyCon -> [Role]
+-- See also Note [TyCon Role signatures]
+tyConRoles tc
+ = case tc of
+ { FunTyCon {} -> const_role Representational
+ ; AlgTyCon { tc_roles = roles } -> roles
+ ; TupleTyCon {} -> const_role Representational
+ ; SynTyCon { tc_roles = roles } -> roles
+ ; PrimTyCon { tc_roles = roles } -> roles
+ ; PromotedDataCon { tc_roles = roles } -> roles
+ ; PromotedTyCon {} -> const_role Nominal
+ }
+ where
+ const_role r = replicate (tyConArity tc) r
+
\end{code}
\begin{code}
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 993507062d..8596dde439 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -48,7 +48,7 @@ module Type (
-- Pred types
mkFamilyTyConApp,
isDictLikeTy,
- mkEqPred, mkPrimEqPred,
+ mkEqPred, mkPrimEqPred, mkReprPrimEqPred,
mkClassPred,
noParenPred, isClassPred, isEqPred,
isIPPred, isIPPred_maybe, isIPTyCon, isIPClass,
@@ -880,6 +880,13 @@ mkPrimEqPred ty1 ty2
TyConApp eqPrimTyCon [k, ty1, ty2]
where
k = typeKind ty1
+
+mkReprPrimEqPred :: Type -> Type -> Type
+mkReprPrimEqPred ty1 ty2
+ = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 )
+ TyConApp eqReprPrimTyCon [k, ty1, ty2]
+ where
+ k = typeKind ty1
\end{code}
--------------------- Dictionary types ---------------------------------
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index ef79974605..e557a6cbb5 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -678,7 +678,7 @@ pprTcApp p pp tc tys
sep (punctuate comma (map (pp TopPrec) ty_args)))
| not opt_PprStyle_Debug
- , getUnique tc `elem` [eqTyConKey, eqPrimTyConKey]
+ , getUnique tc `elem` [eqTyConKey, eqPrimTyConKey, eqReprPrimTyConKey]
-- We need to special case the type equality TyCons because
, [_, ty1,ty2] <- tys -- with kind polymorphism it has 3 args, so won't get printed infix
-- With -dppr-debug switch this off so we can see the kind
diff --git a/compiler/utils/Maybes.lhs b/compiler/utils/Maybes.lhs
index 8a612fbb60..859908e266 100644
--- a/compiler/utils/Maybes.lhs
+++ b/compiler/utils/Maybes.lhs
@@ -14,6 +14,7 @@ module Maybes (
mapCatMaybes,
allMaybes,
firstJust, firstJusts,
+ whenIsJust,
expectJust,
maybeToBool,
@@ -68,6 +69,10 @@ mapCatMaybes _ [] = []
mapCatMaybes f (x:xs) = case f x of
Just y -> y : mapCatMaybes f xs
Nothing -> mapCatMaybes f xs
+
+whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
+whenIsJust (Just x) f = f x
+whenIsJust Nothing _ = return ()
\end{code}
\begin{code}
diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs
index 680300abd4..862af99443 100644
--- a/compiler/utils/UniqFM.lhs
+++ b/compiler/utils/UniqFM.lhs
@@ -20,7 +20,7 @@ and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order
of arguments of combining function.
\begin{code}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveTraversable, GeneralizedNewtypeDeriving #-}
{-# OPTIONS -Wall #-}
module UniqFM (
diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs
index 6d42ce7dfe..dd947ffd93 100644
--- a/compiler/utils/Util.lhs
+++ b/compiler/utils/Util.lhs
@@ -14,7 +14,7 @@ module Util (
-- * General list processing
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
- zipLazy, stretchZipWith,
+ zipLazy, stretchZipWith, zipWithAndUnzip,
unzipWith,
@@ -351,6 +351,14 @@ mapAndUnzip3 f (x:xs)
in
(r1:rs1, r2:rs2, r3:rs3)
+zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d])
+zipWithAndUnzip f (a:as) (b:bs)
+ = let (r1, r2) = f a b
+ (rs1, rs2) = zipWithAndUnzip f as bs
+ in
+ (r1:rs1, r2:rs2)
+zipWithAndUnzip _ _ _ = ([],[])
+
mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b])
mapAccumL2 f s1 s2 xs = (s1', s2', ys)
where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of
diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs
index 9390696fc7..269119c6dd 100644
--- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs
+++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs
@@ -218,7 +218,7 @@ buildToArrPRepr vect_tc repr_co pdata_tc _ r
pdata_co <- mkBuiltinCo pdataTyCon
let co = mkAppCo pdata_co
. mkSymCo
- $ mkUnbranchedAxInstCo repr_co ty_args
+ $ mkUnbranchedAxInstCo Nominal repr_co ty_args
scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg)
@@ -282,7 +282,7 @@ buildFromArrPRepr vect_tc repr_co pdata_tc _ r
pdata_co <- mkBuiltinCo pdataTyCon
let co = mkAppCo pdata_co
- $ mkUnbranchedAxInstCo repr_co var_tys
+ $ mkUnbranchedAxInstCo Nominal repr_co var_tys
let scrut = mkCast (Var arg) co
@@ -368,7 +368,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r
pdatas_co <- mkBuiltinCo pdatasTyCon
let co = mkAppCo pdatas_co
. mkSymCo
- $ mkUnbranchedAxInstCo repr_co ty_args
+ $ mkUnbranchedAxInstCo Nominal repr_co ty_args
let scrut = unwrapFamInstScrut pdatas_tc ty_args (Var varg)
(vars, result) <- to_sum r
@@ -458,7 +458,7 @@ buildFromArrPReprs vect_tc repr_co _ pdatas_tc r
-- Build the coercion between PRepr and the instance type
pdatas_co <- mkBuiltinCo pdatasTyCon
let co = mkAppCo pdatas_co
- $ mkUnbranchedAxInstCo repr_co var_tys
+ $ mkUnbranchedAxInstCo Nominal repr_co var_tys
let scrut = mkCast (Var varg) co
diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs
index 6b06996ec8..37358c9bdf 100644
--- a/compiler/vectorise/Vectorise/Generic/PData.hs
+++ b/compiler/vectorise/Vectorise/Generic/PData.hs
@@ -52,6 +52,7 @@ buildDataFamInst name' fam_tc vect_tc rhs
pat_tys = [mkTyConApp vect_tc tys']
rep_tc = buildAlgTyCon name'
tyvars'
+ (map (const Nominal) tyvars')
Nothing
[] -- no stupid theta
rhs
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 66db6185da..34008efbbd 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -354,7 +354,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
origName = tyConName origTyCon
vectName = tyConName vectTyCon
- mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] (SynonymTyCon ty) NoParentTyCon
+ mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] [] (SynonymTyCon ty) NoParentTyCon
defDataCons
| isAbstract = return ()
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 588cd39ec0..935ea32c69 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -62,6 +62,7 @@ vectTyConDecl tycon name'
False -- include unfoldings on dictionary selectors
name' -- new name: "V:Class"
(tyConTyVars tycon) -- keep original type vars
+ (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety
theta' -- superclasses
(snd . classTvsFds $ cls) -- keep the original functional dependencies
[] -- no associated types (for the moment)
@@ -100,6 +101,7 @@ vectTyConDecl tycon name'
; return $ buildAlgTyCon
name' -- new name
(tyConTyVars tycon) -- keep original type vars
+ (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety
Nothing
[] -- no stupid theta
rhs' -- new constructor defs
diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs
index 0bd54f4408..cb7b34e36a 100644
--- a/compiler/vectorise/Vectorise/Utils/Base.hs
+++ b/compiler/vectorise/Vectorise/Utils/Base.hs
@@ -128,12 +128,12 @@ splitPrimTyCon ty
-- Coercion Construction -----------------------------------------------------
--- |Make a coersion to some builtin type.
+-- |Make a representational coersion to some builtin type.
--
mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
mkBuiltinCo get_tc
= do { tc <- builtin get_tc
- ; return $ mkTyConAppCo tc []
+ ; return $ mkTyConAppCo Representational tc []
}
diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs
index 84a6ff37d9..01fbede4bd 100644
--- a/compiler/vectorise/Vectorise/Utils/PADict.hs
+++ b/compiler/vectorise/Vectorise/Utils/PADict.hs
@@ -145,7 +145,7 @@ prDictOfPReprInstTyCon _ty prepr_ax prepr_args
pr_co <- mkBuiltinCo prTyCon
let co = mkAppCo pr_co
$ mkSymCo
- $ mkUnbranchedAxInstCo prepr_ax prepr_args
+ $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args
return $ mkCast dict co
-- |Get the PR dictionary for a type. The argument must be a representation
diff --git a/docs/core-spec/CoreLint.ott b/docs/core-spec/CoreLint.ott
index c452877ad5..c2dba49612 100644
--- a/docs/core-spec/CoreLint.ott
+++ b/docs/core-spec/CoreLint.ott
@@ -1,3 +1,9 @@
+%%
+%% CoreLint.ott
+%%
+%% defines formal version of core typing rules
+%%
+%% See accompanying README file
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Static semantics %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -54,7 +60,7 @@ t = literalType lit
G |-tm lit : t
G |-tm e : s
-G |-co g : s ~#k t
+G |-co g : s ~Rep k t
------------------- :: Cast
G |-tm e |> g : t
@@ -115,7 +121,7 @@ G |-ty t : k2
---------------------------------------------------- :: Case
G |-tm case e as z_s return t of </ alti // i /> : t
-G |-co g : t1 ~#k t2
+G |-co g : t1 ~Nom k t2
-------------------- :: Coercion
G |-tm g : t1 ~#k t2
@@ -144,88 +150,101 @@ G |-ki k ok
---------------------------------------- :: TyVar
G |-bnd alpha_k ok
-defn G |- co g : t1 ~# k t2 :: :: lintCoercion :: 'Co_'
+defn G |- co g : t1 ~ R k t2 :: :: lintCoercion :: 'Co_'
{{ com Coercion typing, \coderef{coreSyn/CoreLint.lhs}{lintCoercion} }}
- {{ tex [[G]] \labeledjudge{co} [[g]] : [[t1]] \mathop{\sim_{\#}^{[[k]]} } [[t2]] }}
+ {{ tex [[G]] \labeledjudge{co} [[g]] : [[t1]] \mathop{\sim_{[[R]]}^{[[k]]} } [[t2]] }}
by
G |-ty t : k
---------------------- :: Refl
-G |-co <t> : t ~#k t
+G |-co <t>_R : t ~R k t
-G |-co g1 : s1 ~#k1 t1
-G |-co g2 : s2 ~#k2 t2
+G |-co g1 : s1 ~R k1 t1
+G |-co g2 : s2 ~R k2 t2
G |-arrow k1 -> k2 : k
------------------------- :: TyConAppCoFunTy
-G |-co (->) g1 g2 : (s1 -> s2) ~#k (t1 -> t2)
+G |-co (->)_R g1 g2 : (s1 -> s2) ~R k (t1 -> t2)
T /= (->)
-</ G |-co gi : si ~#ki ti // i />
+</ Ri // i /> = tyConRolesX R T
+</ G |-co gi : si ~Ri ki ti // i />
G |-app </ (si : ki) // i /> : tyConKind T ~> k
--------------------------------- :: TyConAppCo
-G |-co T </ gi // i /> : T </ si // i /> ~#k T </ ti // i />
+G |-co T_R </ gi // i /> : T </ si // i /> ~R k T </ ti // i />
-G |-co g1 : s1 ~#k1 t1
-G |-co g2 : s2 ~#k2 t2
+G |-co g1 : s1 ~R k1 t1
+G |-co g2 : s2 ~Nom k2 t2
G |-app (s2 : k2) : k1 ~> k
--------------------- :: AppCo
-G |-co g1 g2 : (s1 s2) ~#k (t1 t2)
+G |-co g1 g2 : (s1 s2) ~R k (t1 t2)
+
+G |-co g1 : s1 ~Ph k1 t1
+G |-co g2 : s2 ~Ph k2 t2
+G |-app (s2 : k2) : k1 ~> k
+--------------------- :: AppCoPhantom
+G |-co g1 g2 : (s1 s2) ~Ph k (t1 t2)
G |-ki k1 ok
-G, z_k1 |-co g : s ~#k2 t
+G, z_k1 |-co g : s ~R k2 t
--------------------------- :: ForAllCo
-G |-co forall z_k1. g : (forall z_k1.s) ~#k2 (forall z_k1.t)
+G |-co forall z_k1. g : (forall z_k1.s) ~R k2 (forall z_k1.t)
z_(t ~#BOX t) elt G
----------------------- :: CoVarCoBox
-G |-co z_(t ~#BOX t) : t ~#BOX t
+G |-co z_(t ~#BOX t) : t ~Nom BOX t
z_(s ~#k t) elt G
k /= BOX
------------------------ :: CoVarCo
-G |-co z_(s ~#k t) : s ~#k t
+----------------------- :: CoVarCoNom
+G |-co z_(s ~#k t) : s ~Nom k t
+
+z_(s ~R#k t) elt G
+k /= BOX
+----------------------- :: CoVarCoRepr
+G |-co z_(s ~R#k t) : s ~Rep k t
G |-ty t1 : k
------------------------------ :: UnsafeCo
-G |-co t1 ==>! t2 : t1 ~#k t2
+----------------------------- :: UnivCo
+G |-co t1 ==>!_R t2 : t1 ~R k t2
-G |-co g : t1 ~#k t2
+G |-co g : t1 ~R k t2
------------------------- :: SymCo
-G |-co sym g : t2 ~#k t1
+G |-co sym g : t2 ~R k t1
-G |-co g1 : t1 ~#k t2
-G |-co g2 : t2 ~#k t3
+G |-co g1 : t1 ~R k t2
+G |-co g2 : t2 ~R k t3
----------------------- :: TransCo
-G |-co g1 ; g2 : t1 ~#k t3
+G |-co g1 ; g2 : t1 ~R k t3
-G |-co g : (T </ sj // j />) ~#k (T </ tj // j />)
+G |-co g : (T </ sj // j />) ~R k (T </ tj // j />)
length </ sj // j /> = length </ tj // j />
i < length </ sj // j />
G |-ty si : k
+R' = (tyConRolesX R T)[i]
---------------------- :: NthCo
-G |-co nth i g : si ~#k ti
+G |-co nth i g : si ~R' k ti
-G |-co g : (s1 s2) ~#k (t1 t2)
+G |-co g : (s1 s2) ~Nom k' (t1 t2)
G |-ty s1 : k
----------------------- :: LRCoLeft
-G |-co Left g : s1 ~#k t1
+G |-co Left g : s1 ~Nom k t1
-G |-co g : (s1 s2) ~#k (t1 t2)
+G |-co g : (s1 s2) ~Nom k' (t1 t2)
G |-ty s2 : k
----------------------- :: LRCoRight
-G |-co Right g : s2 ~#k t2
+G |-co Right g : s2 ~Nom k t2
-G |-co g : forall m.s ~#k forall n.t
+G |-co g : forall m.s ~R k forall n.t
G |-ty t0 : k0
m = z_k1
k0 <: k1
--------------------- :: InstCo
-G |-co g t0 : s[m |-> t0] ~#k t[n |-> t0]
+G |-co g t0 : s[m |-> t0] ~R k t[n |-> t0]
-C = T </ axBranchkk // kk />
+C = T_R0 </ axBranchkk // kk />
0 <= ind < length </ axBranchkk // kk />
-forall </ ni // i />. (</ s1j // j /> ~> t1) = (</ axBranchkk // kk />)[ind]
-</ G |-co gi : s'i ~#k'i t'i // i />
+forall </ ni_Ri // i />. (</ s1j // j /> ~> t1) = (</ axBranchkk // kk />)[ind]
+</ G |-co gi : s'i ~Ri k'i t'i // i />
</ substi @ // i /> = inits(</ [ ni |-> s'i ] // i />)
</ ni = zi_ki // i />
</ k'i <: substi(ki) // i />
@@ -234,7 +253,76 @@ no_conflict(C, </ s2j // j />, ind, ind-1)
t2 = t1 </ [ni |-> t'i] // i />
G |-ty t2 : k
------------------------------------------------------ :: AxiomInstCo
-G |-co C ind </ gi // i /> : T </ s2j // j /> ~#k t2
+G |-co C ind </ gi // i /> : T </ s2j // j /> ~R0 k t2
+
+defn validRoles T :: :: checkValidRoles :: 'Cvr_'
+ {{ com Type constructor role validity, \coderef{typecheck/TcTyClsDecls.lhs}{checkValidRoles} }}
+by
+
+</ Ki // i /> = tyConDataCons T
+</ Rj // j /> = tyConRoles T
+</ validDcRoles </ Rj // j /> Ki // i />
+------------------------------------ :: DataCons
+validRoles T
+
+defn validDcRoles </ Raa // aa /> K :: :: check_dc_roles :: 'Cdr_'
+ {{ com Data constructor role validity, \coderef{typecheck/TcTyClsDecls.lhs}{check\_dc\_roles} }}
+by
+
+forall </ naa // aa />. forall </ mbb // bb />. </ tcc // cc /> @ -> T </ naa // aa /> = dataConRepType K
+</ </ naa : Raa // aa />, </ mbb : Nom // bb /> |- tcc : Rep // cc />
+--------------------------------- :: Args
+validDcRoles </ Raa // aa /> K
+
+defn O |- t : R :: :: check_ty_roles :: 'Ctr_'
+ {{ com Type role validity, \coderef{typecheck/TcTyClsDecls.lhs}{check\_ty\_roles} }}
+ {{ tex [[O]] \labeledjudge{ctr} [[t]] : [[R]] }}
+by
+
+O(n) = R'
+R' <= R
+---------- :: TyVarTy
+O |- n : R
+
+</ Ri // i /> = tyConRoles T
+</ Ri elt { Nom, Rep } => O |- ti : Ri // i />
+-------------------------- :: TyConAppRep
+O |- T </ ti // i /> : Rep
+
+</ O |- ti : Nom // i />
+--------------------------- :: TyConAppNom
+O |- T </ ti // i /> : Nom
+
+O |- t1 : R
+O |- t2 : Nom
+-------------------------- :: AppTy
+O |- t1 t2 : R
+
+O |- t1 : R
+O |- t2 : R
+------------------- :: FunTy
+O |- t1 -> t2 : R
+
+O, n : Nom |- t : R
+--------------------- :: ForAllTy
+O |- forall n. t : R
+
+------------------ :: LitTy
+O |- lit : R
+
+defn R1 <= R2 :: :: ltRole :: 'Rlt_'
+ {{ com Sub-role relation, \coderef{types/Coercion.lhs}{ltRole} }}
+ {{ tex [[R1]] \leq [[R2]] }}
+by
+
+-------- :: Nominal
+Nom <= R
+
+-------- :: Phantom
+R <= Ph
+
+------- :: Refl
+R <= R
defn G |- ki k ok :: :: lintKind :: 'K_'
{{ com Kind validity, \coderef{coreSyn/CoreLint.lhs}{lintKind} }}
@@ -410,24 +498,24 @@ by
------------------------------------------------ :: NoBranch
no_conflict(C, </ si // i/>, ind, -1)
-C = T </ axBranchkk // kk />
-forall </ ni // i />. (</ tj // j /> ~> t') = (</ axBranchkk // kk />)[ind2]
+C = T_R </ axBranchkk // kk />
+forall </ ni_Ri // i />. (</ tj // j /> ~> t') = (</ axBranchkk // kk />)[ind2]
apart(</ sj // j />, </ tj // j />)
no_conflict(C, </ sj // j />, ind1, ind2-1)
------------------------------------------------ :: Incompat
no_conflict(C, </ sj // j />, ind1, ind2)
-C = T </ axBranchkk // kk />
-forall </ ni // i />. (</ tj // j /> ~> s) = (</ axBranchkk // kk />)[ind1]
-forall </ n'i // i />. (</ t'j // j /> ~> s') = (</ axBranchkk // kk />)[ind2]
+C = T_R </ axBranchkk // kk />
+forall </ ni_Ri // i />. (</ tj // j /> ~> s) = (</ axBranchkk // kk />)[ind1]
+forall </ n'i_R'i // i />. (</ t'j // j /> ~> s') = (</ axBranchkk // kk />)[ind2]
apart(</ tj // j />, </ t'j // j />)
no_conflict(C, </ sj // j />, ind1, ind2-1)
------------------------------------------- :: CompatApart
no_conflict(C, </ sj // j />, ind1, ind2)
-C = T </ axBranchkk // kk />
-forall </ ni // i />. (</ tj // j /> ~> s) = (</ axBranchkk // kk />)[ind1]
-forall </ n'i // i />. (</ t'j // j /> ~> s') = (</ axBranchkk // kk />)[ind2]
+C = T_R </ axBranchkk // kk />
+forall </ ni_Ri // i />. (</ tj // j /> ~> s) = (</ axBranchkk // kk />)[ind1]
+forall </ n'i_R'i // i />. (</ t'j // j /> ~> s') = (</ axBranchkk // kk />)[ind2]
unify(</ tj // j />, </ t'j // j />) = subst
subst(s) = subst(s')
----------------------------------------- :: CompatCoincident
diff --git a/docs/core-spec/CoreSyn.ott b/docs/core-spec/CoreSyn.ott
index e6fae08956..ca060f2f72 100644
--- a/docs/core-spec/CoreSyn.ott
+++ b/docs/core-spec/CoreSyn.ott
@@ -1,3 +1,9 @@
+%%
+%% CoreSyn.ott
+%%
+%% defines formal version of core syntax
+%%
+%% See accompanying README file
embed {{ tex-preamble
\newcommand{\coderef}[2]{\ghcfile{#1}:\texttt{#2}%
@@ -93,6 +99,8 @@ t {{ tex \tau }}, k {{ tex \kappa }}, s {{ tex \sigma }}
| tyConKind T :: M :: tyConKind {{ com \coderef{types/TyCon.lhs}{tyConKind} }}
| t1 ~# k t2 :: M :: unliftedEq {{ com Metanotation for coercion types }}
{{ tex [[t1]] \mathop{\sim_{\#}^{[[k]]} } [[t2]] }}
+ | t1 ~R# k t2 :: M :: unliftedREq {{ com Metanotation for coercion types }}
+ {{ tex [[t1]] \mathop{\sim_{\mathsf{R}\#}^{[[k]]} } [[t2]] }}
| literalType t :: M :: literalType {{ com \coderef{basicTypes/Literal.lhs}{literalType} }}
| ( t ) :: M :: parens {{ com Parentheses }}
| t [ n |-> s ] :: M :: TySubst {{ com Type substitution }}
@@ -106,14 +114,14 @@ t {{ tex \tau }}, k {{ tex \kappa }}, s {{ tex \sigma }}
%% COERCIONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
g {{ tex \gamma }} :: 'Coercion_' ::= {{ com Coercions, \coderef{types/Coercion.lhs}{Coercion} }}
- | < t > :: :: Refl {{ com Reflexivity }}
- {{ tex \langle [[t]] \rangle }}
- | T </ gi // i /> :: :: TyConAppCo {{ com Type constructor application }}
+ | < t > _ R :: :: Refl {{ com Reflexivity }}
+ {{ tex {\langle [[t]] \rangle}_{[[R]]} }}
+ | T RA </ gi // i /> :: :: TyConAppCo {{ com Type constructor application }}
| g1 g2 :: :: AppCo {{ com Application }}
| forall n . g :: :: ForAllCo {{ com Polymorphism }}
| n :: :: CoVarCo {{ com Variable }}
| C ind </ gj // j /> :: :: AxiomInstCo {{ com Axiom application }}
- | t1 ==>! t2 :: :: UnsafeCo {{ com Unsafe coercion }}
+ | t1 ==>! RA t2 :: :: UnivCo {{ com Universal coercion }}
| sym g :: :: SymCo {{ com Symmetry }}
| g1 ; g2 :: :: TransCo {{ com Transitivity }}
| nth I g :: :: NthCo {{ com Projection (0-indexed) }}
@@ -128,12 +136,21 @@ LorR :: 'LeftOrRight_' ::= {{ com left or right deconstructor, \coderef{types/Co
| Right :: :: CRight {{ com Right projection }}
C :: 'CoAxiom_' ::= {{ com Axioms, \coderef{types/TyCon.lhs}{CoAxiom} }}
- | T </ axBranchi // ; // i /> :: :: CoAxiom {{ com Axiom }}
+ | T RA </ axBranchi // ; // i /> :: :: CoAxiom {{ com Axiom }}
| ( C ) :: M :: Parens {{ com Parentheses }}
+R {{ tex \rho }} :: 'Role_' ::= {{ com Roles, \coderef{types/CoAxiom.lhs}{Role} }}
+ | Nom :: :: Nominal {{ com Nominal }}
+ {{ tex \mathsf{N} }}
+ | Rep :: :: Representational {{ com Representational }}
+ {{ tex \mathsf{R} }}
+ | Ph :: :: Phantom {{ com Phantom }}
+ {{ tex \mathsf{P} }}
+ | role_list [ i ] :: M :: RoleListIndex {{ com Look up in list }}
+
axBranch, b :: 'CoAxBranch_' ::= {{ com Axiom branches, \coderef{types/TyCon.lhs}{CoAxBranch} }}
- | forall </ ni // i /> . ( </ tj // j /> ~> s ) :: :: CoAxBranch {{ com Axiom branch }}
- | ( </ axBranchi // i /> ) [ ind ] :: M :: lookup {{ com List lookup }}
+ | forall </ ni RAi // i /> . ( </ tj // j /> ~> s ) :: :: CoAxBranch {{ com Axiom branch }}
+ | ( </ axBranchi // i /> ) [ ind ] :: M :: lookup {{ com List lookup }}
%% TYCONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -149,13 +166,14 @@ T :: 'TyCon_' ::= {{ com Type constructors, \coderef{types/TyCon.lhs}{TyCon} }}
| dataConTyCon K :: M :: dataConTyCon {{ com TyCon extracted from DataCon }}
H :: 'PrimTyCon_' ::= {{ com Primitive type constructors, \coderef{prelude/TysPrim.lhs}{} }}
- | Int# :: :: intPrimTyCon {{ com Unboxed Int }}
- | ( ~# ) :: :: eqPrimTyCon {{ com Unboxed equality }}
- | BOX :: :: superKindTyCon {{ com Sort of kinds }}
- | * :: :: liftedTypeKindTyCon {{ com Kind of lifted types }}
- | # :: :: unliftedTypeKindTyCon {{ com Kind of unlifted types }}
- | OpenKind :: :: openTypeKindTyCon {{ com Either $*$ or $\#$ }}
- | Constraint :: :: constraintTyCon {{ com Constraint }}
+ | Int# :: :: intPrimTyCon {{ com Unboxed Int (\texttt{intPrimTyCon}) }}
+ | ( ~# ) :: :: eqPrimTyCon {{ com Unboxed equality (\texttt{eqPrimTyCon}) }}
+ | ( ~R# ) :: :: eqReprPrimTyCon {{ com Unboxed representational equality (\texttt{eqReprPrimTyCon}) }}
+ | BOX :: :: superKindTyCon {{ com Sort of kinds (\texttt{superKindTyCon}) }}
+ | * :: :: liftedTypeKindTyCon {{ com Kind of lifted types (\texttt{liftedTypeKindTyCon}) }}
+ | # :: :: unliftedTypeKindTyCon {{ com Kind of unlifted types (\texttt{unliftedTypeKindTyCon}) }}
+ | OpenKind :: :: openTypeKindTyCon {{ com Either $*$ or $\#$ (\texttt{openTypeKindTyCon}) }}
+ | Constraint :: :: constraintTyCon {{ com Constraint (\texttt{constraintTyCon}) }}
%% CONTEXTS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -164,6 +182,10 @@ G {{ tex \Gamma }} :: 'LintM_Bindings_' ::= {{ com List of bindings, \coderef{co
| </ Gi // , // i /> :: :: Concat {{ com Context concatenation }}
| vars_of binding :: M :: VarsOf {{ com \coderef{coreSyn/CoreSyn.lhs}{bindersOf} }}
+O {{ tex \Omega }} :: 'VarEnv_Role_' ::= {{ com Mapping from type variables to roles }}
+ | </ ni : Ri // i /> :: :: List {{ com List of bindings }}
+ | O1 , O2 :: M :: Concat {{ com Concatenate two lists }}
+
S {{ tex \Sigma }} :: 'St_' ::= {{ com Runtime store }}
| [ n |-> e ] :: :: Binding {{ com Single binding }}
| </ Si // , // i /> :: :: Concat {{ com Store concatentation }}
@@ -201,6 +223,17 @@ ind, I {{ tex i }} :: 'Ind_' ::= {{ com Indices, numbers }}
type_list :: 'TypeList_' ::= {{ com List of types }}
| </ si // i /> :: :: List
+RA {{ tex {\!\!\!{}_{\rho} } }} :: 'RoleAnnot_' ::= {{ com Role annotation }}
+ | _ R :: M :: annotation
+ {{ tex {}_{[[R]]} }}
+
+role_list :: 'RoleList_' ::= {{ com List of roles }}
+ | </ Ri // , // i /> :: :: List
+ | tyConRolesX R T :: M :: tyConRolesX
+ | tyConRoles T :: M :: tyConRoles
+ | ( role_list ) :: M :: Parens
+ | { role_list } :: M :: Braces
+
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Terminals %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -226,6 +259,7 @@ terminals :: 'terminals_' ::=
| BOX :: :: BOX {{ tex \Box }}
| Int# :: :: int_hash {{ tex {\textsf{Int} }_{\#} }}
| ~# :: :: eq_hash {{ tex \mathop{ {\sim}_{\#} } }}
+ | ~R# :: :: eq_repr_hash {{ tex \mathop{ {\sim}_{\mathsf{R}\#} } }}
| OpenKind :: :: OpenKind {{ tex \textsf{OpenKind} }}
| ok :: :: ok {{ tex \textsf{ ok} }}
| no_duplicates :: :: no_duplicates {{ tex \textsf{no\_duplicates } }}
@@ -257,6 +291,11 @@ terminals :: 'terminals_' ::=
| no_conflict :: :: no_conflict {{ tex \textsf{no\_conflict} }}
| apart :: :: apart {{ tex \textsf{apart} }}
| unify :: :: unify {{ tex \textsf{unify} }}
+ | tyConRolesX :: :: tyConRolesX {{ tex \textsf{tyConRolesX} }}
+ | tyConRoles :: :: tyConRoles {{ tex \textsf{tyConRoles} }}
+ | tyConDataCons :: :: tyConDataCons {{ tex \textsf{tyConDataCons} }}
+ | validRoles :: :: validRoles {{ tex \textsf{validRoles} }}
+ | validDcRoles :: :: validDcRoles {{ tex \textsf{validDcRoles} }}
| --> :: :: steps {{ tex \longrightarrow }}
| coercionKind :: :: coercionKind {{ tex \textsf{coercionKind} }}
@@ -303,6 +342,14 @@ formula :: 'formula_' ::=
| C1 = C2 :: :: axiom_rewrite
| apart ( </ ti // i /> , </ sj // j /> ) :: :: apart
| unify ( </ ti // i /> , </ sj // j /> ) = subst :: :: unify
+ | role_list1 = role_list2 :: :: eq_role_list
+ | R1 /= R2 :: :: role_neq
+ | R1 = R2 :: :: eq_role
+ | </ Ki // i /> = tyConDataCons T :: :: tyConDataCons
+ | O ( n ) = R :: :: role_lookup
+ | R elt role_list :: :: role_elt
+ | formula1 => formula2 :: :: implication
+ {{ tex [[formula1]] \implies [[formula2]] }}
| alt1 = alt2 :: :: alt_rewrite
| e1 = e2 :: :: e_rewrite
| no other case matches :: :: no_other_case
@@ -336,4 +383,6 @@ Subst_TmMapping <= Type_TySubstListPost
Expr_Type <= formula_e_rewrite
+Coercion_TyConAppCo <= Coercion_AppCo
+
Expr_Coercion <= Subst_TmMapping
diff --git a/docs/core-spec/OpSem.ott b/docs/core-spec/OpSem.ott
index 53e1f288a9..1c21ada0ec 100644
--- a/docs/core-spec/OpSem.ott
+++ b/docs/core-spec/OpSem.ott
@@ -83,7 +83,7 @@ S |- case e as n return t of </ alti // i /> --> u[n |-> e]
T </ taa // aa /> ~#k T </ t'aa // aa /> = coercionKind g
forall </ alphaaa_kaa // aa />. forall </ betabb_k'bb // bb />. </ t1cc // cc /> @-> T </ alphaaa_kaa // aa /> = dataConRepType K
-</ e'cc = ecc |> (t1cc @ </ [alphaaa_kaa |-> nth aa g] // aa /> </ [betabb_k'bb |-> <sbb>] // bb />) // cc />
+</ e'cc = ecc |> (t1cc @ </ [alphaaa_kaa |-> nth aa g] // aa /> </ [betabb_k'bb |-> <sbb>_Nom] // bb />) // cc />
--------------------------- :: CasePush
S |- case (K </ taa // aa /> </ sbb // bb /> </ ecc // cc />) |> g as n return t2 of </ alti // i /> --> case K </ t'aa // aa /> </ sbb // bb /> </ e'cc // cc /> as n return t2 of </ alti // i />
diff --git a/docs/core-spec/README b/docs/core-spec/README
index e193955490..1fb304d261 100644
--- a/docs/core-spec/README
+++ b/docs/core-spec/README
@@ -64,7 +64,7 @@ your notation to LaTeX. Three different homs are used:
help disambiguate otherwise-ambiguous parses. Getting these right is hard,
so if you have trouble, you're not alone.
-- In one place, it was necessary to use an @ symbol to disambiguate parses. The
+- In a few places, it is necessary to use an @ symbol to disambiguate parses. The
@ symbol is not typeset and is used solely for disambiguation. Feel free to use
it if necessary to disambiguate other parses.
diff --git a/docs/core-spec/core-spec.mng b/docs/core-spec/core-spec.mng
index 246be067fc..2e8134c7a1 100644
--- a/docs/core-spec/core-spec.mng
+++ b/docs/core-spec/core-spec.mng
@@ -7,6 +7,7 @@
\usepackage{xcolor}
\usepackage{fullpage}
\usepackage{multirow}
+\usepackage{url}
\newcommand{\ghcfile}[1]{\textsl{#1}}
\newcommand{\arraylabel}[1]{\multicolumn{2}{l}{\!\!\!\!\!\!\!\!\!\text{\underline{#1}:}}}
@@ -19,7 +20,7 @@
\setlength{\parindent}{0in}
\setlength{\parskip}{1ex}
-\newcommand{\gram}[1]{\ottgrammartabular{#1\ottinterrule}}
+\newcommand{\gram}[1]{\ottgrammartabular{#1\ottafterlastrule}}
\begin{document}
@@ -148,13 +149,21 @@ a term-level literal, but we are ignoring this distinction here.
Invariants on coercions:
\begin{itemize}
-\item $[[<t1 t2>]]$ is used; never $[[<t1> <t2>]]$.
-\item If $[[<T>]]$ is applied to some coercions, at least one of which is not
-reflexive, use $[[T </ gi // i />]]$, never $[[<T> g1 g2]] \ldots$.
-\item The $[[T]]$ in $[[T </gi//i/>]]$ is never a type synonym, though it could
+\item $[[<t1 t2>_R]]$ is used; never $[[<t1>_R <t2>_Nom]]$.
+\item If $[[<T>_R]]$ is applied to some coercions, at least one of which is not
+reflexive, use $[[T_R </ gi // i />]]$, never $[[<T>_R g1 g2]] \ldots$.
+\item The $[[T]]$ in $[[T_R </gi//i/>]]$ is never a type synonym, though it could
be a type function.
\end{itemize}
+Roles label what equality relation a coercion is a witness of. Nominal equality
+means that two types are identical (have the same name); representational equality
+means that two types have the same representation (introduced by newtypes); and
+phantom equality includes all types. See \url{http://ghc.haskell.org/trac/ghc/wiki/Roles}
+for more background.
+
+\gram{\ottR}
+
Is it a left projection or a right projection?
\gram{\ottLorR}
@@ -285,12 +294,22 @@ a dead id and for one-tuples. These checks are omitted here.
\subsection{Coercion typing}
+In the coercion typing judgment, the $\#$ marks are left off the equality
+operators to reduce clutter. This is not actually inconsistent, because
+the GHC function that implements this check, \texttt{lintCoercion}, actually
+returns four separate values (the kind, the two types, and the role), not
+a type with head $[[(~#)]]$ or $[[(~R#)]]$. Note that the difference between
+these two forms of equality is interpreted in the rules \ottdrulename{Co\_CoVarCoNom}
+and \ottdrulename{Co\_CoVarCoRepr}.
+
\ottdefnlintCoercion{}
In \ottdrulename{Co\_AxiomInstCo}, the use of $[[inits]]$ creates substitutions from
the first $i$ mappings in $[[ </ [ni |-> si] // i /> ]]$. This has the effect of
folding the substitution over the kinds for kind-checking.
+See Section~\ref{sec:tyconroles} for more information about $[[tyConRolesX]]$.
+
\subsection{Name consistency}
There are two very similar checks for names, one declared as a local function:
@@ -327,6 +346,31 @@ There are two very similar checks for names, one declared as a local function:
\ottdefnisSubKind{}
+\subsection{Roles}
+\label{sec:tyconroles}
+
+During type-checking, role inference is carried out, assigning roles to the
+arguments of every type constructor. The function $[[tyConRoles]]$ extracts these
+roles. Also used in other judgments is $[[tyConRolesX]]$, which is the same as
+$[[tyConRoles]]$, but with an arbitrary number of $[[Nom]]$ at the end, to account
+for potential oversaturation.
+
+The checks encoded in the following
+judgments are run from \coderef{typecheck/TcTyClsDecls.lhs}{checkValidTyCon}
+when \texttt{-dcore-lint} is set.
+
+\ottdefncheckValidRoles{}
+
+\ottdefncheckXXdcXXroles{}
+
+In the following judgment, the role $[[R]]$ is an \emph{input}, not an output.
+
+\ottdefncheckXXtyXXroles{}
+
+These judgments depend on a sub-role relation:
+
+\ottdefnltRole{}
+
\subsection{Branched axiom conflict checking}
\label{sec:no_conflict}
diff --git a/docs/core-spec/core-spec.pdf b/docs/core-spec/core-spec.pdf
index 180d9bed78..cb21286abb 100644
--- a/docs/core-spec/core-spec.pdf
+++ b/docs/core-spec/core-spec.pdf
Binary files differ
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index f972a4bd56..8111a81e63 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -3525,7 +3525,7 @@ dictionary, only slower!
</para>
-<sect3> <title> Generalising the deriving clause </title>
+<sect3 id="generalized-newtype-deriving"> <title> Generalising the deriving clause </title>
<para>
GHC now permits such instances to be derived instead,
using the flag <option>-XGeneralizedNewtypeDeriving</option>,
@@ -3646,6 +3646,8 @@ where
derive these classes for a newtype, but it happens in the usual way, not
via this new mechanism.
</para></listitem>
+<listitem><para>
+ The role of the last parameter of each of the <literal>ci</literal> is <emphasis>not</emphasis> <literal>N</literal>. (See <xref linkend="roles"/>.)</para></listitem>
</itemizedlist>
Then, for each <literal>ci</literal>, the derived instance
declaration is:
@@ -10707,7 +10709,214 @@ Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh.
</sect1>
+<sect1 id="roles">
+<title>Roles
+<indexterm><primary>roles</primary></indexterm>
+</title>
+
+<para>
+Using <option>-XGeneralizedNewtypeDeriving</option> (<xref
+linkend="generalized-newtype-deriving" />), a programmer can take existing
+instances of classes and "lift" these into instances of that class for a
+newtype. However, this is not always safe. For example, consider the following:
+</para>
+
+<programlisting>
+ newtype Age = MkAge { unAge :: Int }
+
+ type family Inspect x
+ type instance Inspect Age = Int
+ type instance Inspect Int = Bool
+
+ class BadIdea a where
+ bad :: a -> Inspect a
+
+ instance BadIdea Int where
+ bad = (> 0)
+
+ deriving instance BadIdea Age -- not allowed!
+</programlisting>
+
+<para>
+If the derived instance were allowed, what would the type of its method
+<literal>bad</literal> be? It would seem to be <literal>Age -> Inspect
+Age</literal>, which is equivalent to <literal>Age -> Int</literal>, according
+to the type family <literal>Inspect</literal>. Yet, if we simply adapt the
+implementation from the instance for <literal>Int</literal>, the implementation
+for <literal>bad</literal> produces a <literal>Bool</literal>, and we have trouble.
+</para>
+
+<para>
+The way to identify such situations is to have <emphasis>roles</emphasis> assigned
+to type variables of datatypes, classes, and type synonyms.</para>
+
+<para>
+Roles as implemented in GHC are a from a simplified version of the work
+described in <ulink
+url="http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf">Generative
+type abstraction and type-level computation</ulink>, published at POPL 2011.</para>
+
+<sect2>
+<title>Nominal, Representational, and Phantom</title>
+
+<para>The goal of the roles system is to track when two types have the same
+underlying representation. In the example above, <literal>Age</literal> and
+<literal>Int</literal> have the same representation. But, the corresponding
+instances of <literal>BadIdea</literal> would <emphasis>not</emphasis> have
+the same representation, because the types of the implementations of
+<literal>bad</literal> would be different.</para>
+
+<para>Suppose we have two uses of a type constructor, each applied to the same
+parameters except for one difference. (For example, <literal>T Age Bool
+c</literal> and <literal>T Int Bool c</literal> for some type
+<literal>T</literal>.) The role of a type parameter says what we need to
+know about the two differing type arguments in order to know that the two
+outer types have the same representation (in the example, what must be true
+about <literal>Age</literal> and <literal>Int</literal> in order to show that
+<literal>T Age Bool c</literal> has the same representation as <literal>
+T Int Bool c</literal>).</para>
+
+<para>GHC supports three different roles for type parameters: nominal,
+representational, and phantom. If a type parameter has a nominal (N) role,
+then the two types that differ must not actually differ at all: they must be
+identical (after type family reduction). If a type parameter has a
+representational (R) role, then the two types must have the same
+representation. (If <literal>T</literal>'s first parameter's role is R, then
+<literal>T Age Bool c</literal> and <literal>T Int Bool c</literal> would have
+the same representation, because <literal>Age</literal> and <literal>Int</literal>
+have the same representation.) If a type parameter has a phantom (P) role,
+then we need no further information.</para>
+
+<para>Here are some examples:</para>
+
+<programlisting>
+ data Simple a = MkSimple a -- a has role R
+
+ type family F
+ type instance F Int = Bool
+ type instance F Age = Char
+
+ data Complex a = MkComplex (F a) -- a has role N
+
+ data Phant a = MkPhant Bool -- a has role P
+</programlisting>
+
+<para>The type <literal>Simple</literal> has its parameter at role R, which is
+generally the most common case. <literal>Simple Age</literal> would have the same
+representation as <literal>Simple Int</literal>. The type <literal>Complex</literal>,
+on the other hand, has its parameter at role N, because <literal>Simple Age</literal>
+and <literal>Simple Int</literal> are <emphasis>not</emphasis> the same. Lastly,
+<literal>Phant Age</literal> and <literal>Phant Bool</literal> have the same
+representation, even though <literal>Age</literal> and <literal>Bool</literal>
+are unrelated.</para>
+
+</sect2>
+
+<sect2>
+<title>Role inference</title>
+
+<para>
+What role should a given type parameter should have? GHC performs role
+inference to determine the correct role for every parameter. It starts with a
+few base facts: <literal>(->)</literal> has two R parameters;
+<literal>(~)</literal> has two N parameters; all type families' parameters are
+N; and all GADT-like parameters are N. Then, these facts are propagated to all
+places where these types are used. By defaulting parameters to role P, any
+parameters unused in the right-hand side (or used only in other types in P
+positions) will be P. Whenever a parameter is used in an R position (that is,
+used as a type argument to a constructor whose corresponding variable is at
+role R), we raise its role from P to R. Similarly, when a parameter is used in
+an N position, its role is upgraded to N. We never downgrade a role from N to
+P or R, or from R to P. In this way, we infer the most-general role for each
+parameter.
+</para>
+
+<para>There is one particularly tricky case that should be explained:</para>
+
+<programlisting>
+ data Tricky a b = MkTricky (a b)
+</programlisting>
+
+<para>What should <literal>Tricky</literal>'s roles be? At first blush, it would
+seem that both <literal>a</literal> and <literal>b</literal> should be at role R,
+since both are used in the right-hand side and neither is involved in a type family.
+However, this would be wrong, as the following example shows:</para>
+<programlisting>
+ data Nom a = MkNom (F a) -- type family F from example above
+</programlisting>
+
+<para>Is <literal>Tricky Nom Age</literal> representationally equal to
+<literal>Tricky Nom Int</literal>? No! The former stores a <literal>Char</literal>
+and the latter stores a <literal>Bool</literal>. The solution to this is
+to require all parameters to type variables to have role N. Thus, GHC would
+infer role R for <literal>a</literal> but role N for <literal>b</literal>.</para>
+
+</sect2>
+
+<sect2>
+<title>Role annotations
+<indexterm><primary>-XRoleAnnotations</primary></indexterm>
+</title>
+
+<para>
+Sometimes the programmer wants to constrain the inference process. For
+example, the base library contains the following definition:
+</para>
+
+<programlisting>
+ data Ptr a = Ptr Addr#
+</programlisting>
+
+<para>
+The idea is that <literal>a</literal> should really be an R parameter, but
+role inference assigns it to P. This makes some level of sense: a pointer to
+an <literal>Int</literal> really is representationally the same as a pointer
+to a <literal>Bool</literal>. But, that's not at all how we want to use
+<literal>Ptr</literal>s! So, we want to be able to say</para>
+
+<programlisting>
+ data Ptr a@R = Ptr Addr#
+</programlisting>
+
+<para>
+The <literal>@R</literal> (enabled with <option>-XRoleAnnotations</option>) annotation forces the
+parameter a to be at role R, not role P. GHC then checks
+the user-supplied roles to make sure they don't break any promises. It would
+be bad, for example, if the user could make <literal>BadIdea</literal>'s role be R.
+</para>
+
+<para>The other place where role annotations may be necessary are in
+<literal>hs-boot</literal> files (<xref linkend="mutual-recursion"/>), where
+the right-hand sides of definitions can be omitted. As usual, the
+types/classes declared in an <literal>hs-boot</literal> file must match up
+with the definitions in the <literal>hs</literal> file, including down to the
+roles. The default role is R in <literal>hs-boot</literal> files,
+corresponding to the common use case.</para>
+
+<para>
+Role annotations are allowed on type variables in data, newtype, class,
+and type declarations. They are not allowed on type/data family
+declarations or in explicit foralls in function type signatures.
+The syntax for a role annotation is an <literal>@</literal> sign followed
+by one of <literal>N</literal>, <literal>R</literal>, or <literal>P</literal>,
+directly following a type variable. If the type variable has an explicit
+kind annotation, the role annotation goes after the kind annotation, outside
+the parentheses. Here are some examples:</para>
+
+<programlisting>
+ data T1 a b@P = MkT1 a -- b is not used; annotation is fine but unnecessary
+ data T2 a b@P = MkT2 b -- ERROR: b is used and cannot be P
+ data T3 a b@N = MkT3 a -- OK: N is higher than necessary, but safe
+ data T4 (a :: * -> *)@N = MkT4 (a Int) -- OK, but N is higher than necessary
+ class C a@R b where ... -- OK
+ type X a@N = ... -- OK
+ type family F a@R -- ERROR: annotations not allowed on family declarations
+</programlisting>
+
+</sect2>
+
+</sect1>
<!-- Emacs stuff:
;;; Local Variables: ***