Expand type synonyms during role inference
authorRyan Scott <ryan.gl.scott@gmail.com>
Sat, 12 Aug 2017 19:52:08 +0000 (15:52 -0400)
committerRyan Scott <ryan.gl.scott@gmail.com>
Sat, 12 Aug 2017 19:52:09 +0000 (15:52 -0400)
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

compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs
compiler/types/Coercion.hs

index 8915364..ba35db5 100644 (file)
@@ -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) $
index 41482cc..e55b8e8 100644 (file)
@@ -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
index b0b13b8..214fe2d 100644 (file)
@@ -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