diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 0c5ceea80fd7fc90466fcd7cbf837b953ece646b..817fbb36e039b7812220002bbdb8b16c9b68973c 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 dbecf0a754029825fedddaecffa3b05e59d2f38d..b26c56de1293ca224d8d2e5ef269d71726748188 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 d90cc7aa00785f230a135f859342c90597354142..796433e1b79ae8fd9d62573564630cd8f1fa6dde 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 ed17c5c5e6ed850b19839b696fedd99d46cf5bae..99ed2d6f12b526807730bdf054d0a64c9d328331 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 0000000000000000000000000000000000000000..b3c2910e2ec706f24766360ed7557ea862a60a94 --- /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 0000000000000000000000000000000000000000..e40865fc6402a274b9bd18a8b32acf6ac6858b7b --- /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 f77e61f55d200f454c273d87a157c1827d23d9bc..4555b0f84eae77d176ed83f8f337c648f0c2e2fd 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'])