[commit: ghc] master: Fix #8773. (1382975)
git at git.haskell.org
git at git.haskell.org
Thu Feb 13 23:10:10 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/138297585f88351352e0ed878b25f26e1d6edfef/ghc
>---------------------------------------------------------------
commit 138297585f88351352e0ed878b25f26e1d6edfef
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date: Thu Feb 13 14:22:20 2014 -0500
Fix #8773.
To make a role annotation on a class asserting a role other than
nominal, you now need -XIncoherentInstances. See the ticket for
more information as to why this is a good idea.
>---------------------------------------------------------------
138297585f88351352e0ed878b25f26e1d6edfef
compiler/typecheck/TcTyClsDecls.lhs | 14 ++++++++++++++
testsuite/tests/roles/should_compile/Roles14.hs | 7 +++++++
testsuite/tests/roles/should_compile/Roles14.stderr | 14 ++++++++++++++
testsuite/tests/roles/should_compile/Roles4.hs | 4 ----
testsuite/tests/roles/should_compile/Roles4.stderr | 6 ------
testsuite/tests/roles/should_compile/all.T | 1 +
testsuite/tests/roles/should_fail/T8773.hs | 7 +++++++
testsuite/tests/roles/should_fail/T8773.stderr | 5 +++++
testsuite/tests/roles/should_fail/all.T | 1 +
9 files changed, 49 insertions(+), 10 deletions(-)
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 1fbdbb2..0c5ceea 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1694,6 +1694,15 @@ checkValidRoleAnnots role_annots thing
; checkTc (type_vars `equalLength` the_role_annots)
(wrongNumberOfRoles type_vars decl)
; _ <- zipWith3M checkRoleAnnot type_vars the_role_annots type_roles
+ -- Representational or phantom roles for class parameters
+ -- quickly lead to incoherence. So, we require
+ -- IncoherentInstances to have them. See #8773.
+ ; incoherent_roles_ok <- xoptM Opt_IncoherentInstances
+ ; checkTc ( incoherent_roles_ok
+ || (not $ isClassTyCon tc)
+ || (all (== Nominal) type_roles))
+ incoherentRoles
+
; lint <- goptM Opt_DoCoreLinting
; when lint $ checkValidRoles tc }
@@ -2180,6 +2189,11 @@ needXRoleAnnotations tc
= ptext (sLit "Illegal role annotation for") <+> ppr tc <> char ';' $$
ptext (sLit "did you intend to use RoleAnnotations?")
+incoherentRoles :: SDoc
+incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+>
+ text "for class parameters can lead to incoherence.") $$
+ (text "Use IncoherentInstances to allow this; bad role found")
+
addTyThingCtxt :: TyThing -> TcM a -> TcM a
addTyThingCtxt thing
= addErrCtxt ctxt
diff --git a/testsuite/tests/roles/should_compile/Roles14.hs b/testsuite/tests/roles/should_compile/Roles14.hs
new file mode 100644
index 0000000..121aad7
--- /dev/null
+++ b/testsuite/tests/roles/should_compile/Roles14.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE RoleAnnotations, IncoherentInstances #-}
+
+module Roles12 where
+
+type role C2 representational
+class C2 a where
+ meth2 :: a -> a
diff --git a/testsuite/tests/roles/should_compile/Roles14.stderr b/testsuite/tests/roles/should_compile/Roles14.stderr
new file mode 100644
index 0000000..1323193
--- /dev/null
+++ b/testsuite/tests/roles/should_compile/Roles14.stderr
@@ -0,0 +1,14 @@
+TYPE SIGNATURES
+TYPE CONSTRUCTORS
+ C2 :: * -> Constraint
+ class C2 a
+ Roles: [representational]
+ RecFlag NonRecursive
+ meth2 :: a -> a
+COERCION AXIOMS
+ axiom Roles12.NTCo:C2 :: C2 a = a -> a
+Dependent modules: []
+Dependent packages: [base, ghc-prim, integer-gmp]
+
+==================== Typechecker ====================
+
diff --git a/testsuite/tests/roles/should_compile/Roles4.hs b/testsuite/tests/roles/should_compile/Roles4.hs
index b5c404a..d7aa78f 100644
--- a/testsuite/tests/roles/should_compile/Roles4.hs
+++ b/testsuite/tests/roles/should_compile/Roles4.hs
@@ -6,10 +6,6 @@ type role C1 nominal
class C1 a where
meth1 :: a -> a
-type role C2 representational
-class C2 a where
- meth2 :: a -> a
-
type Syn1 a = [a]
class C3 a where
diff --git a/testsuite/tests/roles/should_compile/Roles4.stderr b/testsuite/tests/roles/should_compile/Roles4.stderr
index e69b852..32862ea 100644
--- a/testsuite/tests/roles/should_compile/Roles4.stderr
+++ b/testsuite/tests/roles/should_compile/Roles4.stderr
@@ -5,11 +5,6 @@ TYPE CONSTRUCTORS
Roles: [nominal]
RecFlag NonRecursive
meth1 :: a -> a
- C2 :: * -> Constraint
- class C2 a
- Roles: [representational]
- RecFlag NonRecursive
- meth2 :: a -> a
C3 :: * -> Constraint
class C3 a
Roles: [nominal]
@@ -19,7 +14,6 @@ TYPE CONSTRUCTORS
type Syn1 a = [a]
COERCION AXIOMS
axiom Roles4.NTCo:C1 :: C1 a = a -> a
- axiom Roles4.NTCo:C2 :: C2 a = a -> a
axiom Roles4.NTCo:C3 :: C3 a = a -> Syn1 a
Dependent modules: []
Dependent packages: [base, ghc-prim, integer-gmp]
diff --git a/testsuite/tests/roles/should_compile/all.T b/testsuite/tests/roles/should_compile/all.T
index 266a260..a016de3 100644
--- a/testsuite/tests/roles/should_compile/all.T
+++ b/testsuite/tests/roles/should_compile/all.T
@@ -3,4 +3,5 @@ test('Roles2', only_ways('normal'), compile, ['-ddump-tc'])
test('Roles3', only_ways('normal'), compile, ['-ddump-tc'])
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, [''])
\ No newline at end of file
diff --git a/testsuite/tests/roles/should_fail/T8773.hs b/testsuite/tests/roles/should_fail/T8773.hs
new file mode 100644
index 0000000..d0984b4
--- /dev/null
+++ b/testsuite/tests/roles/should_fail/T8773.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE RoleAnnotations #-}
+
+module T8773 where
+
+type role C2 representational
+class C2 a where
+ meth2 :: a -> a
diff --git a/testsuite/tests/roles/should_fail/T8773.stderr b/testsuite/tests/roles/should_fail/T8773.stderr
new file mode 100644
index 0000000..838d587
--- /dev/null
+++ b/testsuite/tests/roles/should_fail/T8773.stderr
@@ -0,0 +1,5 @@
+
+T8773.hs:5:1:
+ Roles other than ‛nominal’ for class parameters can lead to incoherence.
+ Use IncoherentInstances to allow this; bad role found
+ while checking a role annotation for ‛C2’
diff --git a/testsuite/tests/roles/should_fail/all.T b/testsuite/tests/roles/should_fail/all.T
index 0e30472..d0d5c4d 100644
--- a/testsuite/tests/roles/should_fail/all.T
+++ b/testsuite/tests/roles/should_fail/all.T
@@ -7,3 +7,4 @@ test('Roles11', normal, compile_fail, [''])
test('Roles12',
extra_clean(['Roles12.o-boot', 'Roles12.hi-boot']),
run_command, ['$MAKE --no-print-directory -s Roles12'])
+test('T8773', normal, compile_fail, [''])
\ No newline at end of file
More information about the ghc-commits
mailing list