[commit: ghc] master: Make role inference work on the source type of a data con (e30c84c)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/e30c84cb5adcd35e4b8301804af39df605ffcc7f/ghc

>---------------------------------------------------------------

commit e30c84cb5adcd35e4b8301804af39df605ffcc7f
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Sep 4 12:07:01 2013 +0100

    Make role inference work on the source type of a data con
    
    When inferring roles it is Much More Kosher to work on the source
    type, as written by the user, rather than the representation type as
    computed by GHC.  Error messages may be better and, more subtly, the
    representation type is the result of a pretty complicated calculation
    and I'm worried about accidental cycles.


>---------------------------------------------------------------

e30c84cb5adcd35e4b8301804af39df605ffcc7f
 compiler/typecheck/TcTyClsDecls.lhs |   16 +++++++++-------
 compiler/typecheck/TcTyDecls.lhs    |   22 +++++++++++++++++++---
 2 files changed, 28 insertions(+), 10 deletions(-)

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 70e72f5..f4e4dab 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1524,14 +1524,16 @@ checkValidRoles tc
   = 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)
+      = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc))
+           ; mapM_ (check_ty_roles role_env Representational) $
+                    eqSpecPreds eq_spec ++ theta ++ arg_tys }
+                    -- See Note [Role-checking data constructor arguments] in TcTyDecls
+      where
+        (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig 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
+        ex_roles   = mkVarEnv (zip ex_tvs (repeat Nominal))
+        role_env   = univ_roles `plusVarEnv` ex_roles
 
     check_ty_roles env role (TyVarTy tv)
       = case lookupVarEnv env tv of
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index bea2cd1..5091cab 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -615,6 +615,19 @@ roles(~#) = N, N
 With -dcore-lint on, the output of this algorithm is checked in checkValidRoles,
 called from checkValidTycon.
 
+Note [Role-checking data constructor arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data T a where
+    MkT :: Eq b => F a -> (a->a) -> T (G a)
+
+Then we want to check the roles at which 'a' is used
+in MkT's type.  We want to work on the user-written type,
+so we need to take into account
+  * the arguments:   (F a) and (a->a)
+  * the context:     C a b
+  * the result type: (G a)   -- this is in the eq_spec
+
 \begin{code}
 type RoleEnv    = NameEnv [Role]        -- from tycon names to roles
 type RoleAnnots = NameEnv [Maybe Role]  -- from tycon names to role annotations,
@@ -695,9 +708,12 @@ irClass tc_name cls
 -- 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)
+  = addRoleInferenceInfo tc_name univ_tvs $
+    mapM_ (irType ex_var_set) (eqSpecPreds eq_spec ++ theta ++ arg_tys)
+      -- See Note [Role-checking data constructor arguments] 
+  where
+    (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig datacon
+    ex_var_set = mkVarSet ex_tvs
 
 irType :: VarSet -> Type -> RoleM ()
 irType = go