[commit: ghc] master: Expand type synonyms during role inference (0bb1e84)

[git at git.haskell.org]

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

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

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

commit 0bb1e84034a12d7f700b48fca6710c01bd08f397
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Sat Aug 12 15:52:08 2017 -0400

    Expand type synonyms during role inference
    
    Summary:
    During role inference, we need to expand type synonyms, since
    oversaturated applications of type synonym tycons would otherwise have overly
    conservative roles inferred for its arguments.
    
    Fixes #14101.
    
    Test Plan: ./validate
    
    Reviewers: goldfire, austin, bgamari
    
    Reviewed By: goldfire
    
    Subscribers: rwbarton, thomie
    
    GHC Trac Issues: #14101
    
    Differential Revision: https://phabricator.haskell.org/D3838


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

0bb1e84034a12d7f700b48fca6710c01bd08f397
 compiler/typecheck/TcTyClsDecls.hs | 4 ++++
 compiler/typecheck/TcTyDecls.hs    | 2 ++
 compiler/types/Coercion.hs         | 2 ++
 3 files changed, 8 insertions(+)

diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 8915364..ba35db5 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -2994,6 +2994,10 @@ checkValidRoles tc
         ex_roles   = mkVarEnv (map (, Nominal) ex_tvs)
         role_env   = univ_roles `plusVarEnv` ex_roles
 
+    check_ty_roles env role ty
+      | Just ty' <- coreView ty -- #14101
+      = check_ty_roles env role ty'
+
     check_ty_roles env role (TyVarTy tv)
       = case lookupVarEnv env tv of
           Just role' -> unless (role' `ltRole` role || role' == role) $
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 41482cc..e55b8e8 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -580,6 +580,8 @@ irDataCon datacon
 irType :: VarSet -> Type -> RoleM ()
 irType = go
   where
+    go lcls ty                 | Just ty' <- coreView ty -- #14101
+                               = go lcls ty'
     go lcls (TyVarTy tv)       = unless (tv `elemVarSet` lcls) $
                                  updateRole Representational tv
     go lcls (AppTy t1 t2)      = go lcls t1 >> markNominal lcls t2
diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs
index b0b13b8..214fe2d 100644
--- a/compiler/types/Coercion.hs
+++ b/compiler/types/Coercion.hs
@@ -1513,6 +1513,8 @@ ty_co_subst lc role ty
   = go role ty
   where
     go :: Role -> Type -> Coercion
+    go r ty                | Just ty' <- coreView ty
+                           = go r ty'
     go Phantom ty          = lift_phantom ty
     go r (TyVarTy tv)      = expectJust "ty_co_subst bad roles" $
                              liftCoSubstTyVar lc r tv