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



Repository : ssh:[email protected]/ghc

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

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

commit 0bb1e84034a12d7f700b48fca6710c01bd08f397
Author: Ryan Scott <[email protected]>
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

_______________________________________________
ghc-commits mailing list
[email protected]
http://mail.haskell.org/cgi-bin/mailman/listinfo/ghc-commits



Programming list archiving by: Enterprise Git Hosting