diff options
| author | Ryan Scott <ryan.gl.scott@gmail.com> | 2017-08-12 15:52:08 -0400 |
|---|---|---|
| committer | Ryan Scott <ryan.gl.scott@gmail.com> | 2017-08-12 15:52:09 -0400 |
| commit | 0bb1e84034a12d7f700b48fca6710c01bd08f397 (patch) | |
| tree | a3fc50116f19566baf68365785655a003217c834 | |
| parent | 4f1f9868ae79b5730c6aa14b05394d3f1d10a857 (diff) | |
| download | haskell-0bb1e84034a12d7f700b48fca6710c01bd08f397.tar.gz | |
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
| -rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs | 4 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyDecls.hs | 2 | ||||
| -rw-r--r-- | compiler/types/Coercion.hs | 2 |
3 files changed, 8 insertions, 0 deletions
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 8915364dbd..ba35db5f3d 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 41482cca8e..e55b8e8503 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 b0b13b85ec..214fe2d92e 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 |