Fix #8773.
authorRichard Eisenberg <eir@cis.upenn.edu>
Thu, 13 Feb 2014 19:22:20 +0000 (14:22 -0500)
committerRichard Eisenberg <eir@cis.upenn.edu>
Thu, 13 Feb 2014 20:37:02 +0000 (15:37 -0500)
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.

compiler/typecheck/TcTyClsDecls.lhs
testsuite/tests/roles/should_compile/Roles14.hs [new file with mode: 0644]
testsuite/tests/roles/should_compile/Roles14.stderr [new file with mode: 0644]
testsuite/tests/roles/should_compile/Roles4.hs
testsuite/tests/roles/should_compile/Roles4.stderr
testsuite/tests/roles/should_compile/all.T
testsuite/tests/roles/should_fail/T8773.hs [new file with mode: 0644]
testsuite/tests/roles/should_fail/T8773.stderr [new file with mode: 0644]
testsuite/tests/roles/should_fail/all.T

index 1fbdbb2..0c5ceea 100644 (file)
@@ -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 (file)
index 0000000..121aad7
--- /dev/null
@@ -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 (file)
index 0000000..1323193
--- /dev/null
@@ -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 ====================
+
index b5c404a..d7aa78f 100644 (file)
@@ -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
index e69b852..32862ea 100644 (file)
@@ -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]
index 266a260..a016de3 100644 (file)
@@ -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 (file)
index 0000000..d0984b4
--- /dev/null
@@ -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 (file)
index 0000000..838d587
--- /dev/null
@@ -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’
index 0e30472..d0d5c4d 100644 (file)
@@ -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