Implement "roles" into GHC.

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

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

This fixes Trac #1496, #4846, #7148.

6 files changed, 11 insertions, 8 deletions

diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs
index 9390696fc7..269119c6dd 100644
--- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs
+++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs
@@ -218,7 +218,7 @@ buildToArrPRepr vect_tc repr_co pdata_tc _ r
       pdata_co <- mkBuiltinCo pdataTyCon
       let co           = mkAppCo pdata_co
                        . mkSymCo
-                       $ mkUnbranchedAxInstCo repr_co ty_args
+                       $ mkUnbranchedAxInstCo Nominal repr_co ty_args
 
           scrut   = unwrapFamInstScrut pdata_tc ty_args (Var arg)
 
@@ -282,7 +282,7 @@ buildFromArrPRepr vect_tc repr_co pdata_tc _ r
 
       pdata_co <- mkBuiltinCo pdataTyCon
       let co           = mkAppCo pdata_co
-                       $ mkUnbranchedAxInstCo repr_co var_tys
+                       $ mkUnbranchedAxInstCo Nominal repr_co var_tys
 
       let scrut        = mkCast (Var arg) co
 
@@ -368,7 +368,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r
     pdatas_co <- mkBuiltinCo pdatasTyCon
     let co           = mkAppCo pdatas_co
                      . mkSymCo
-                     $ mkUnbranchedAxInstCo repr_co ty_args
+                     $ mkUnbranchedAxInstCo Nominal repr_co ty_args
 
     let scrut        = unwrapFamInstScrut pdatas_tc ty_args (Var varg)
     (vars, result)  <- to_sum r
@@ -458,7 +458,7 @@ buildFromArrPReprs vect_tc repr_co _ pdatas_tc r
     -- Build the coercion between PRepr and the instance type
     pdatas_co <- mkBuiltinCo pdatasTyCon
     let co           = mkAppCo pdatas_co
-                     $ mkUnbranchedAxInstCo repr_co var_tys
+                     $ mkUnbranchedAxInstCo Nominal repr_co var_tys
 
     let scrut        = mkCast (Var varg) co
 
diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs
index 6b06996ec8..37358c9bdf 100644
--- a/compiler/vectorise/Vectorise/Generic/PData.hs
+++ b/compiler/vectorise/Vectorise/Generic/PData.hs
@@ -52,6 +52,7 @@ buildDataFamInst name' fam_tc vect_tc rhs
             pat_tys  = [mkTyConApp vect_tc tys']
             rep_tc   = buildAlgTyCon name'
                            tyvars'
+                           (map (const Nominal) tyvars')
                            Nothing
                            []          -- no stupid theta
                            rhs
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 66db6185da..34008efbbd 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -354,7 +354,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
         origName  = tyConName origTyCon
         vectName  = tyConName vectTyCon
 
-        mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] (SynonymTyCon ty) NoParentTyCon
+        mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] [] (SynonymTyCon ty) NoParentTyCon
         
         defDataCons
           | isAbstract = return ()
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 588cd39ec0..935ea32c69 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -62,6 +62,7 @@ vectTyConDecl tycon name'
                      False                      -- include unfoldings on dictionary selectors
                      name'                      -- new name: "V:Class"
                      (tyConTyVars tycon)        -- keep original type vars
+                     (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety
                      theta'                     -- superclasses
                      (snd . classTvsFds $ cls)  -- keep the original functional dependencies
                      []                         -- no associated types (for the moment)
@@ -100,6 +101,7 @@ vectTyConDecl tycon name'
        ; return $ buildAlgTyCon 
                     name'                   -- new name
                     (tyConTyVars tycon)     -- keep original type vars
+                    (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety
                     Nothing
                     []                      -- no stupid theta
                     rhs'                    -- new constructor defs
diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs
index 0bd54f4408..cb7b34e36a 100644
--- a/compiler/vectorise/Vectorise/Utils/Base.hs
+++ b/compiler/vectorise/Vectorise/Utils/Base.hs
@@ -128,12 +128,12 @@ splitPrimTyCon ty
 
 -- Coercion Construction -----------------------------------------------------
 
--- |Make a coersion to some builtin type.
+-- |Make a representational coersion to some builtin type.
 --
 mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
 mkBuiltinCo get_tc
   = do { tc <- builtin get_tc
-       ; return $ mkTyConAppCo tc []
+       ; return $ mkTyConAppCo Representational tc []
        }
 
 
diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs
index 84a6ff37d9..01fbede4bd 100644
--- a/compiler/vectorise/Vectorise/Utils/PADict.hs
+++ b/compiler/vectorise/Vectorise/Utils/PADict.hs
@@ -145,7 +145,7 @@ prDictOfPReprInstTyCon _ty prepr_ax prepr_args
       pr_co <- mkBuiltinCo prTyCon
       let co = mkAppCo pr_co
              $ mkSymCo
-             $ mkUnbranchedAxInstCo prepr_ax prepr_args
+             $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args
       return $ mkCast dict co
 
 -- |Get the PR dictionary for a type. The argument must be a representation