diff options
| author | Richard Eisenberg <eir@cis.upenn.edu> | 2013-08-02 15:47:03 +0100 |
|---|---|---|
| committer | Richard Eisenberg <eir@cis.upenn.edu> | 2013-08-02 15:47:03 +0100 |
| commit | e8aa8ccba0c40884765281b21ff8f4411802dd41 (patch) | |
| tree | e29e041226a8cb34a1aeca77f824b22db5a9be0f | |
| parent | 303d3de9b52f67b9234f94d0e77e0933ca572ce7 (diff) | |
| download | haskell-e8aa8ccba0c40884765281b21ff8f4411802dd41.tar.gz | |
Implement "roles" into GHC.
Roles are a solution to the GeneralizedNewtypeDeriving type-safety
problem.
Roles were first described in the "Generative type abstraction" paper,
by Stephanie Weirich, Dimitrios Vytiniotis, Simon PJ, and Steve Zdancewic.
The implementation is a little different than that paper. For a quick
primer, check out Note [Roles] in Coercion. Also see
http://ghc.haskell.org/trac/ghc/wiki/Roles
and
http://ghc.haskell.org/trac/ghc/wiki/RolesImplementation
For a more formal treatment, check out docs/core-spec/core-spec.pdf.
This fixes Trac #1496, #4846, #7148.
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 Binary files differindex 180d9bed78..cb21286abb 100644 --- a/docs/core-spec/core-spec.pdf +++ b/docs/core-spec/core-spec.pdf 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: *** |