[commit: ghc] ghc-7.10: Rename role annotations w.r.t only local decls. (4e14780)
git at git.haskell.org
git at git.haskell.org
Mon May 11 10:07:14 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-7.10
Link : http://ghc.haskell.org/trac/ghc/changeset/4e147807b3d4f51b4fb7aa593cc444e86349ad8f/ghc
>---------------------------------------------------------------
commit 4e147807b3d4f51b4fb7aa593cc444e86349ad8f
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date: Fri Apr 10 22:25:29 2015 +0100
Rename role annotations w.r.t only local decls.
Fix #10263.
(cherry picked from commit 6ab5da9913e4f8a8dcc8bda3c77d4e896fd67352)
>---------------------------------------------------------------
4e147807b3d4f51b4fb7aa593cc444e86349ad8f
compiler/rename/RnEnv.hs | 15 +++++++++++++--
compiler/rename/RnSource.hs | 19 ++++++++++++-------
testsuite/tests/ghci/scripts/T8485.stderr | 6 +++---
testsuite/tests/roles/should_compile/T10263.hs | 5 +++++
testsuite/tests/roles/should_compile/all.T | 1 +
5 files changed, 34 insertions(+), 12 deletions(-)
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index d422fbe..6f9ae93 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -17,6 +17,7 @@ module RnEnv (
reportUnboundName,
HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
+ lookupSigCtxtOccRn,
lookupFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName,
@@ -1064,13 +1065,22 @@ data HsSigCtxt
| ClsDeclCtxt Name -- Class decl for this class
| InstDeclCtxt Name -- Intsance decl for this class
| HsBootCtxt -- Top level of a hs-boot file
+ | RoleAnnotCtxt NameSet -- A role annotation, with the names of all types
+ -- in the group
lookupSigOccRn :: HsSigCtxt
-> Sig RdrName
-> Located RdrName -> RnM (Located Name)
-lookupSigOccRn ctxt sig
+lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)
+
+-- | Lookup a name in relation to the names in a 'HsSigCtxt'
+lookupSigCtxtOccRn :: HsSigCtxt
+ -> SDoc -- ^ description of thing we're looking up,
+ -- like "type family"
+ -> Located RdrName -> RnM (Located Name)
+lookupSigCtxtOccRn ctxt what
= wrapLocM $ \ rdr_name ->
- do { mb_name <- lookupBindGroupOcc ctxt (hsSigDoc sig) rdr_name
+ do { mb_name <- lookupBindGroupOcc ctxt what rdr_name
; case mb_name of
Left err -> do { addErr err; return (mkUnboundName rdr_name) }
Right name -> return name }
@@ -1098,6 +1108,7 @@ lookupBindGroupOcc ctxt what rdr_name
= case ctxt of
HsBootCtxt -> lookup_top (const True) True
TopSigCtxt ns meth_ok -> lookup_top (`elemNameSet` ns) meth_ok
+ RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns) False
LocalBindCtxt ns -> lookup_group ns
ClsDeclCtxt cls -> lookup_cls_op cls
InstDeclCtxt cls -> lookup_cls_op cls
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 11ea659..b4117e8 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -943,7 +943,8 @@ rnTyClDecls :: [Name] -> [TyClGroup RdrName]
-- Rename the declarations and do depedency analysis on them
rnTyClDecls extra_deps tycl_ds
= do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
- ; role_annot_env <- rnRoleAnnots (concatMap group_roles tycl_ds)
+ ; let decl_names = mkNameSet (map (tcdName . unLoc . fst) ds_w_fvs)
+ ; role_annot_env <- rnRoleAnnots decl_names (concatMap group_roles tycl_ds)
; thisPkg <- fmap thisPackage getDynFlags
; let add_boot_deps :: FreeVars -> FreeVars
-- See Note [Extra dependencies from .hs-boot files]
@@ -1082,13 +1083,14 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
rnTySyn doc rhs = rnLHsType doc rhs
--- Renames role annotations, returning them as the values in a NameEnv
+-- | Renames role annotations, returning them as the values in a NameEnv
-- and checks for duplicate role annotations.
-- It is quite convenient to do both of these in the same place.
-- See also Note [Role annotations in the renamer]
-rnRoleAnnots :: [LRoleAnnotDecl RdrName]
- -> RnM (NameEnv (LRoleAnnotDecl Name))
-rnRoleAnnots role_annots
+rnRoleAnnots :: NameSet -- ^ of the decls in this group
+ -> [LRoleAnnotDecl RdrName]
+ -> RnM (NameEnv (LRoleAnnotDecl Name))
+rnRoleAnnots decl_names role_annots
= do { -- check for duplicates *before* renaming, to avoid lumping
-- together all the unboundNames
let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
@@ -1104,8 +1106,11 @@ rnRoleAnnots role_annots
, not (isUnboundName name) ] }
where
rn_role_annot1 (RoleAnnotDecl tycon roles)
- = do { -- the name is an *occurrence*
- tycon' <- wrapLocM lookupGlobalOccRn tycon
+ = do { -- the name is an *occurrence*, but look it up only in the
+ -- decls defined in this group (see #10263)
+ tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt decl_names)
+ (text "role annotation")
+ tycon
; return $ RoleAnnotDecl tycon' roles }
dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
diff --git a/testsuite/tests/ghci/scripts/T8485.stderr b/testsuite/tests/ghci/scripts/T8485.stderr
index 6635882..bbef720 100644
--- a/testsuite/tests/ghci/scripts/T8485.stderr
+++ b/testsuite/tests/ghci/scripts/T8485.stderr
@@ -1,4 +1,4 @@
-<interactive>:3:1:
- Role annotation for a type previously declared: type role X nominal
- (The role annotation must be given where ‘X’ is declared.)
+<interactive>:3:11: error:
+ The role annotation for ‘X’ lacks an accompanying binding
+ (The role annotation must be given where ‘X’ is declared)
diff --git a/testsuite/tests/roles/should_compile/T10263.hs b/testsuite/tests/roles/should_compile/T10263.hs
new file mode 100644
index 0000000..d12a3a4
--- /dev/null
+++ b/testsuite/tests/roles/should_compile/T10263.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE RoleAnnotations #-}
+module T10263 where
+
+data Maybe a = AF
+type role Maybe representational
diff --git a/testsuite/tests/roles/should_compile/all.T b/testsuite/tests/roles/should_compile/all.T
index 0bd779f..2e0d8ea 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('T8958', [normalise_fun(normalise_errmsg), only_ways('normal')], compile, ['-ddump-tc -dsuppress-uniques'])
+test('T10263', normal, compile, [''])
More information about the ghc-commits
mailing list