Implement "roles" into GHC.
authorRichard Eisenberg <eir@cis.upenn.edu>
Fri, 2 Aug 2013 14:47:03 +0000 (15:47 +0100)
committerRichard Eisenberg <eir@cis.upenn.edu>
Fri, 2 Aug 2013 14:47:03 +0000 (15:47 +0100)
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:
compiler/basicTypes/DataCon.lhs
compiler/basicTypes/MkId.lhs
compiler/cmm/SMRep.lhs
compiler/coreSyn/CoreLint.lhs
compiler/coreSyn/CoreSubst.lhs
compiler/coreSyn/CoreUtils.lhs
compiler/coreSyn/ExternalCore.lhs
compiler/coreSyn/MkExternalCore.lhs
compiler/coreSyn/PprExternalCore.lhs
compiler/coreSyn/TrieMap.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsForeign.lhs
compiler/deSugar/DsMeta.hs
compiler/ghci/ByteCodeAsm.lhs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/iface/BinIface.hs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/IfaceType.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/DynFlags.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/parser/ParserCore.y
compiler/parser/RdrHsSyn.lhs
compiler/prelude/PrelNames.lhs
compiler/prelude/PrelRules.lhs
compiler/prelude/TysPrim.lhs
compiler/prelude/TysWiredIn.lhs
compiler/rename/RnTypes.lhs
compiler/simplCore/SimplUtils.lhs
compiler/specialise/Rules.lhs
compiler/specialise/SpecConstr.lhs
compiler/stranal/WwLib.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcEvidence.lhs
compiler/typecheck/TcForeign.lhs
compiler/typecheck/TcGenGenerics.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcTyDecls.lhs
compiler/typecheck/TcType.lhs
compiler/types/Class.lhs
compiler/types/CoAxiom.lhs
compiler/types/Coercion.lhs
compiler/types/FamInstEnv.lhs
compiler/types/OptCoercion.lhs
compiler/types/TyCon.lhs
compiler/types/Type.lhs
compiler/types/TypeRep.lhs
compiler/utils/Maybes.lhs
compiler/utils/UniqFM.lhs
compiler/utils/Util.lhs
compiler/vectorise/Vectorise/Generic/PAMethods.hs
compiler/vectorise/Vectorise/Generic/PData.hs
compiler/vectorise/Vectorise/Type/Env.hs
compiler/vectorise/Vectorise/Type/TyConDecl.hs
compiler/vectorise/Vectorise/Utils/Base.hs
compiler/vectorise/Vectorise/Utils/PADict.hs
docs/core-spec/CoreLint.ott
docs/core-spec/CoreSyn.ott
docs/core-spec/OpSem.ott
docs/core-spec/README
docs/core-spec/core-spec.mng
docs/core-spec/core-spec.pdf
docs/users_guide/glasgow_exts.xml

index 42032d4..eba5c8b 100644 (file)
@@ -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
 
index 218033a..14e29c1 100644 (file)
@@ -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
index 6f569ef..c54f6d5 100644 (file)
@@ -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}
 
 %************************************************************************
 %*                                                                      *
index f9256e1..5befacd 100644 (file)
@@ -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 ty)
   = do { k <- lintType ty
-       ; return (k, ty, ty) }
+       ; return (k, ty, ty, r) }
 
-lintCoercion co@(TyConAppCo tc cos)
+lintCoercion co@(TyConAppCo 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}
 
 %************************************************************************
index bc9c767..25a751b 100644 (file)
@@ -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
index 00f704f..c872ac3 100644 (file)
@@ -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
index f002c3a..ecc24b1 100644 (file)
@@ -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
 
index e84dff9..a0776af 100644 (file)
@@ -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
index 24ee560..7fd3ac1 100644 (file)
@@ -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
index c5cd990..f8ad8da 100644 (file)
@@ -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}
 
 
index 66022f9..617516b 100644 (file)
@@ -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
index 9be8e96..1053b91 100644 (file)
@@ -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
index a60f18d..f92f621 100644 (file)
@@ -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
index 9906467..e3119a7 100644 (file)
@@ -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,
index f7d5bdb..383b641 100644 (file)
@@ -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' }
index eeed5cd..82b0cf2 100644 (file)
@@ -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)
index 1fa9496..267b2ca 100644 (file)
@@ -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}
 
 
index 0876d90..b0bb887 100644 (file)
@@ -415,3 +415,4 @@ getWayDescr dflags
         -- if this is an unregisterised build, make sure our interfaces
         -- can't be used by a registerised build.
 
+
index a541e32..20aea22 100644 (file)
@@ -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
index 7eb3d3a..3bbcdd3 100644 (file)
@@ -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 })
index c3b59b7..b9d6a44 100644 (file)
@@ -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}
 
index d9bd6fc..bf48f88 100644 (file)
@@ -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)
 
 ---------------------
index f6b4e40..c379199 100644 (file)
@@ -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
index 0bbd819..64ec8be 100644 (file)
@@ -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 ),
index 11d849a..c97d38f 100644 (file)
@@ -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
index af29753..b35bbf3 100644 (file)
@@ -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
 
index 0e78794..2a4c957 100644 (file)
@@ -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
 
index e8c23ca..1e61cf9 100644 (file)
@@ -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)
index 2d795ab..8452092 100644 (file)
@@ -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
index b569840..6faecaa 100644 (file)
@@ -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
 
index a10300a..f166065 100644 (file)
@@ -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
index b8c0e34..b563b25 100644 (file)
@@ -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)
index fb55ac9..a1c4bac 100644 (file)
@@ -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
index 92874de..4e40e31 100644 (file)
@@ -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
index c214812..b88888c 100644 (file)
@@ -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
index c1486d3..a5df7d5 100644 (file)
@@ -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
index 810db20..ca64a7f 100644 (file)
@@ -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
index 21e2bbb..ebb5b85 100644 (file)
@@ -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]
index eab839a..a18dc21 100644 (file)
@@ -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
index f65681e..9914f94 100644 (file)
@@ -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 
index f4765e9..7e2b014 100644 (file)
@@ -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
index d26f371..ba027b1 100644 (file)
@@ -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}
 
 %************************************************************************
index 2156bba..79ce573 100644 (file)
@@ -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]
index c0a0760..23d63ba 100644 (file)
@@ -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]
index 56cdf60..d96dd22 100644 (file)
@@ -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) }
index 59b06d4..bb24708 100644 (file)
@@ -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)
index 4d7f70d..1479273 100644 (file)
@@ -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}
index fb54899..bea2cd1 100644 (file)
@@ -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}
 
 %************************************************************************
 %*                                                                      *
index a3d3156..8a8de41 100644 (file)
@@ -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
index 312ce84..7a1251f 100644 (file)
@@ -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.
 
 
 %************************************************************************
index 7781d56..e507607 100644 (file)
@@ -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
index 0c85667..6cda16b 100644 (file)
@@ -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 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 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 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 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 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 tvs cos ty
+  = liftCoSubst (zipEqual "liftCoSubstWith" tvs cos) ty
 
-liftCoSubst :: [(TyVar,Coercion)] -> Type -> Coercion
-liftCoSubst prs ty
- | null prs  = Refl ty
+liftCoSubst :: Role -> [(TyVar,Coercion)] -> Type -> Coercion
+liftCoSubst prs ty
+ | null prs  = Refl ty
  | otherwise = ty_co_subst (LCS (mkInScopeSet (tyCoVarsOfCos (map snd prs)))
-                                (mkVarEnv prs)) ty
+                                (mkVarEnv prs)) 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]
index 63a4c50..b6fdb35 100644 (file)
@@ -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
+norma