Commit 6ab5da99 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Rename role annotations w.r.t only local decls.

Fix #10263.
parent 524ddbda
......@@ -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
......
......@@ -951,7 +951,8 @@ rnTyClDecls :: Maybe FreeVars -> [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)
; this_mod <- getModule
; let add_boot_deps :: FreeVars -> FreeVars
-- See Note [Extra dependencies from .hs-boot files]
......@@ -1094,13 +1095,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
......@@ -1116,8 +1118,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 ()
......
<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)
{-# LANGUAGE RoleAnnotations #-}
module T10263 where
data Maybe a = AF
type role Maybe representational
......@@ -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, [''])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment