[commit: ghc] ghc-7.8: Fix #8958. (63c0b7b)
git at git.haskell.org
git at git.haskell.org
Mon Apr 7 14:05:57 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-7.8
Link : http://ghc.haskell.org/trac/ghc/changeset/63c0b7bb8ca357e56bf524bbaf2765a0a693edb1/ghc
>---------------------------------------------------------------
commit 63c0b7bb8ca357e56bf524bbaf2765a0a693edb1
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date: Sat Apr 5 13:56:00 2014 -0400
Fix #8958.
We now do role inference on stupid datatype contexts, allowing a
lightweight role annotation syntax.
(cherry picked from commit d468cd376ffc02cf9f4755275a316be914c482be)
>---------------------------------------------------------------
63c0b7bb8ca357e56bf524bbaf2765a0a693edb1
compiler/typecheck/TcTyClsDecls.lhs | 3 +-
compiler/typecheck/TcTyDecls.lhs | 4 +-
testsuite/tests/ghci/scripts/ghci031.stdout | 4 +-
.../tests/rename/should_fail/rnfail055.stderr | 5 +-
testsuite/tests/roles/should_compile/T8958.hs | 13 ++++++
testsuite/tests/roles/should_compile/T8958.stderr | 49 ++++++++++++++++++++
testsuite/tests/roles/should_compile/all.T | 1 +
7 files changed, 74 insertions(+), 5 deletions(-)
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 0c5ceea..817fbb3 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -780,7 +780,8 @@ tcDataDefn rec_info tc_name tvs kind
= do { extra_tvs <- tcDataKindSig kind
; let final_tvs = tvs ++ extra_tvs
roles = rti_roles rec_info tc_name
- ; stupid_theta <- tcHsContext ctxt
+ ; stupid_tc_theta <- tcHsContext ctxt
+ ; stupid_theta <- zonkTcTypeToTypes emptyZonkEnv stupid_tc_theta
; kind_signatures <- xoptM Opt_KindSignatures
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index dbecf0a..b26c56d 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -709,6 +709,8 @@ irTyCon tc
; unless (all (== Nominal) old_roles) $ -- also catches data families,
-- which don't want or need role inference
do { whenIsJust (tyConClass_maybe tc) (irClass tc_name)
+ ; addRoleInferenceInfo tc_name (tyConTyVars tc) $
+ mapM_ (irType emptyVarSet) (tyConStupidTheta tc) -- See #8958
; mapM_ (irDataCon tc_name) (visibleDataCons $ algTyConRhs tc) }}
| Just (SynonymTyCon ty) <- synTyConRhs_maybe tc
@@ -778,7 +780,7 @@ lookupRoles tc
Just roles -> return roles
Nothing -> return $ tyConRoles tc }
--- tries to update a role; won't even update a role "downwards"
+-- tries to update a role; won't ever update a role "downwards"
updateRole :: Role -> TyVar -> RoleM ()
updateRole role tv
= do { var_ns <- getVarNs
diff --git a/testsuite/tests/ghci/scripts/ghci031.stdout b/testsuite/tests/ghci/scripts/ghci031.stdout
index d90cc7a..796433e 100644
--- a/testsuite/tests/ghci/scripts/ghci031.stdout
+++ b/testsuite/tests/ghci/scripts/ghci031.stdout
@@ -1 +1,3 @@
-data Eq a => D a = C a -- Defined at ghci031.hs:7:1
+type role D nominal
+data Eq a => D a = C a
+ -- Defined at ghci031.hs:7:1
diff --git a/testsuite/tests/rename/should_fail/rnfail055.stderr b/testsuite/tests/rename/should_fail/rnfail055.stderr
index ed17c5c..99ed2d6 100644
--- a/testsuite/tests/rename/should_fail/rnfail055.stderr
+++ b/testsuite/tests/rename/should_fail/rnfail055.stderr
@@ -32,9 +32,10 @@ RnFail055.hs-boot:12:1:
RnFail055.hs-boot:14:1:
Type constructor ‘T2’ has conflicting definitions in the module
and its hs-boot file
- Main module: type role T2 representational phantom
+ Main module: type role T2 representational nominal
data Eq b => T2 a b = T2 a
- Boot file: data Eq a => T2 a b = T2 a
+ Boot file: type role T2 nominal representational
+ data Eq a => T2 a b = T2 a
RnFail055.hs-boot:16:11:
T3 is exported by the hs-boot file, but not exported by the module
diff --git a/testsuite/tests/roles/should_compile/T8958.hs b/testsuite/tests/roles/should_compile/T8958.hs
new file mode 100644
index 0000000..b3c2910
--- /dev/null
+++ b/testsuite/tests/roles/should_compile/T8958.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE RoleAnnotations, DatatypeContexts, IncoherentInstances,
+ FlexibleInstances #-}
+
+module T8958 where
+
+class Nominal a
+instance Nominal a
+
+class Representational a
+instance Representational a
+type role Representational representational
+
+newtype (Nominal k, Representational v) => Map k v = MkMap [(k,v)]
diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr
new file mode 100644
index 0000000..e40865f
--- /dev/null
+++ b/testsuite/tests/roles/should_compile/T8958.stderr
@@ -0,0 +1,49 @@
+
+T8958.hs:1:31: Warning:
+ -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
+TYPE SIGNATURES
+TYPE CONSTRUCTORS
+ Map :: * -> * -> *
+ newtype (Nominal k, Representational v) => Map k v
+ No C type associated
+ Roles: [nominal, representational]
+ RecFlag NonRecursive, Promotable
+ = MkMap :: [(k, v)] -> Map k v Stricts: _
+ FamilyInstance: none
+ Nominal :: * -> Constraint
+ class Nominal a
+ Roles: [nominal]
+ RecFlag NonRecursive
+ Representational :: * -> Constraint
+ class Representational a
+ Roles: [representational]
+ RecFlag NonRecursive
+COERCION AXIOMS
+ axiom T8958.NTCo:Map :: Map k v = [(k, v)]
+INSTANCES
+ instance [incoherent] Representational a
+ -- Defined at T8958.hs:10:10
+ instance [incoherent] Nominal a -- Defined at T8958.hs:7:10
+Dependent modules: []
+Dependent packages: [base, ghc-prim, integer-gmp]
+
+==================== Typechecker ====================
+AbsBinds [a] []
+ {Exports: [T8958.$fRepresentationala <= $dRepresentational_aJ6
+ <>]
+ Exported types: T8958.$fRepresentationala [InlPrag=[ALWAYS] CONLIKE]
+ :: forall a. Representational a
+ [LclIdX[DFunId],
+ Str=DmdType,
+ Unf=DFun: \ (@ a) -> T8958.D:Representational TYPE a]
+ Binds: $dRepresentational_aJ6 = T8958.D:Representational}
+AbsBinds [a] []
+ {Exports: [T8958.$fNominala <= $dNominal_aJ7
+ <>]
+ Exported types: T8958.$fNominala [InlPrag=[ALWAYS] CONLIKE]
+ :: forall a. Nominal a
+ [LclIdX[DFunId],
+ Str=DmdType,
+ Unf=DFun: \ (@ a) -> T8958.D:Nominal TYPE a]
+ Binds: $dNominal_aJ7 = T8958.D:Nominal}
+
diff --git a/testsuite/tests/roles/should_compile/all.T b/testsuite/tests/roles/should_compile/all.T
index f77e61f..4555b0f 100644
--- a/testsuite/tests/roles/should_compile/all.T
+++ b/testsuite/tests/roles/should_compile/all.T
@@ -5,3 +5,4 @@ test('Roles4', only_ways('normal'), compile, ['-ddump-tc'])
test('Roles13', only_ways('normal'), compile, ['-ddump-simpl -dsuppress-uniques'])
test('Roles14', only_ways('normal'), compile, ['-ddump-tc'])
test('RolesIArray', only_ways('normal'), compile, [''])
+test('T8958', only_ways('normal'), compile, ['-ddump-tc'])
More information about the ghc-commits
mailing list