[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