Fix Trac #8485.

The problem was that the renamer treated role annotations by looking
up the annotated type in the module being compiled. If this check
succeeded, it was assumed that the annotated type was being compiled
at the same time. But this assumption is false! In GHCi (and Template
Haskell), sometimes compilation within one module can be staged. So,
now there is a more intricate check for orphan role annotations. This
also has the benefit of producing better error messages.

compiler/rename/RnEnv.lhs

@@ -22,7 +22,7 @@ module RnEnv (
         lookupSubBndrGREs, lookupConstructorFields,
         lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse,
         lookupGreRn, lookupGreRn_maybe,
-        lookupGlobalOccInThisModule, lookupGreLocalRn_maybe, 
+        lookupGreLocalRn_maybe, 
         getLookupOccRn, addUsedRdrNames,
 
         newLocalBndrRn, newLocalBndrsRn,
@@ -704,19 +704,6 @@ lookupGreLocalRn_maybe rdr_name
   where
     lookup_fn env = filter isLocalGRE (lookupGRE_RdrName rdr_name env)
 
-lookupGlobalOccInThisModule :: RdrName -> RnM Name
--- If not found, add error message
-lookupGlobalOccInThisModule rdr_name
-  | Just n <- isExact_maybe rdr_name
-  = do { n' <- lookupExactOcc n; return n' }
-
-  | otherwise
-  = do { mb_gre <- lookupGreLocalRn_maybe rdr_name
-       ; case mb_gre of
-           Just gre -> return $ gre_name gre
-           Nothing -> do { traceRn (text "lookupGlobalInThisModule" <+> ppr rdr_name)
-                         ; unboundName WL_LocalTop rdr_name } }
-
 lookupGreRn_help :: RdrName                     -- Only used in error message
                  -> (GlobalRdrEnv -> [GlobalRdrElt])    -- Lookup function
                  -> RnM (Maybe GlobalRdrElt)

compiler/rename/RnSource.lhs

@@ -892,12 +892,21 @@ rnTyClDecls extra_deps tycl_ds
 
              raw_groups = map flattenSCC sccs
              -- See Note [Role annotations in the renamer]
-             groups = [ TyClGroup { group_tyclds = gp
-                                  , group_roles = roles }
-                      | gp <- raw_groups
-                      , let roles = mapMaybe ( lookupNameEnv role_annot_env
-                                             . tcdName
-                                             . unLoc ) gp ]
+             (groups, orphan_roles)
+               = foldr (\group (groups_acc, orphans_acc) ->
+                         let names = map (tcdName . unLoc) group
+                             roles = mapMaybe (lookupNameEnv orphans_acc) names
+                             orphans' = delListFromNameEnv orphans_acc names
+                              -- there doesn't seem to be an interface to
+                              -- do the above more efficiently
+                         in ( TyClGroup { group_tyclds = group
+                                        , group_roles  = roles } : groups_acc
+                            , orphans' )
+                       )
+                       ([], role_annot_env)
+                       raw_groups
+                 
+       ; mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
        ; traceRn (text "rnTycl"  <+> (ppr ds_w_fvs $$ ppr sccs))
        ; return (groups, all_fvs) }
 
@@ -1031,7 +1040,7 @@ rnRoleAnnots role_annots
   where
     rn_role_annot1 (RoleAnnotDecl tycon roles)
       = do {  -- the name is an *occurrence*
-             tycon' <- wrapLocM lookupGlobalOccInThisModule tycon
+             tycon' <- wrapLocM lookupGlobalOccRn tycon
            ; return $ RoleAnnotDecl tycon' roles }
 
 dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
@@ -1050,6 +1059,15 @@ dupRoleAnnotErr list
 
       cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
 
+orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM ()
+orphanRoleAnnotErr (L loc decl)
+  = addErrAt loc $
+    hang (text "Role annotation for a type previously declared:")
+       2 (ppr decl) $$
+    parens (text "The role annotation must be given where" <+>
+            quotes (ppr $ roleAnnotDeclName decl) <+>
+            text "is declared.")
+
 rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars)
 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
                            , dd_ctxt = context, dd_cons = condecls 
@@ -1186,14 +1204,25 @@ type, if any. Then, this map can be used to add the role annotations to the
 groups after dependency analysis.
 
 This process checks for duplicate role annotations, where we must be careful
-to filter out the unbound annotations to avoid reporting spurious duplicates.
-We hold off doing other checks until validity checking in the type checker.
-
-Also, note that the tycon in a role annotation is renamed with
-lookupGlobalInThisModule. We want only annotations for local declarations.
-Because all of these are in scope by this point, this renaming technique
-also effectively identifies any orphan role annotations. Annotations on
-declarations that don't support them is checked for in the type-checker.
+to do the check *before* renaming to avoid calling all unbound names duplicates
+of one another.
+
+The renaming process, as usual, might identify and report errors for unbound
+names. We exclude the annotations for unbound names in the annotation
+environment to avoid spurious errors for orphaned annotations.
+
+We then (in rnTyClDecls) do a check for orphan role annotations (role
+annotations without an accompanying type decl). The check works by folding
+over raw_groups (of type [[TyClDecl Name]]), selecting out the relevant
+role declarations for each group, as well as diminishing the annotation
+environment. After the fold is complete, anything left over in the name
+environment must be an orphan, and errors are generated.
+
+An earlier version of this algorithm short-cut the orphan check by renaming
+only with names declared in this module. But, this check is insufficient in
+the case of staged module compilation (Template Haskell, GHCi).
+See #8485. With the new lookup process (which includes types declared in other
+modules), we get better error messages, too.
 
 %*********************************************************
 %*                                                      *