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 ( ...@@ -17,6 +17,7 @@ module RnEnv (
reportUnboundName, reportUnboundName,
HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
lookupSigCtxtOccRn,
lookupFixityRn, lookupTyFixityRn, lookupFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName, lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName,
...@@ -1064,13 +1065,22 @@ data HsSigCtxt ...@@ -1064,13 +1065,22 @@ data HsSigCtxt
| ClsDeclCtxt Name -- Class decl for this class | ClsDeclCtxt Name -- Class decl for this class
| InstDeclCtxt Name -- Intsance decl for this class | InstDeclCtxt Name -- Intsance decl for this class
| HsBootCtxt -- Top level of a hs-boot file | HsBootCtxt -- Top level of a hs-boot file
| RoleAnnotCtxt NameSet -- A role annotation, with the names of all types
-- in the group
lookupSigOccRn :: HsSigCtxt lookupSigOccRn :: HsSigCtxt
-> Sig RdrName -> Sig RdrName
-> Located RdrName -> RnM (Located Name) -> 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 -> = wrapLocM $ \ rdr_name ->
do { mb_name <- lookupBindGroupOcc ctxt (hsSigDoc sig) rdr_name do { mb_name <- lookupBindGroupOcc ctxt what rdr_name
; case mb_name of ; case mb_name of
Left err -> do { addErr err; return (mkUnboundName rdr_name) } Left err -> do { addErr err; return (mkUnboundName rdr_name) }
Right name -> return name } Right name -> return name }
...@@ -1098,6 +1108,7 @@ lookupBindGroupOcc ctxt what rdr_name ...@@ -1098,6 +1108,7 @@ lookupBindGroupOcc ctxt what rdr_name
= case ctxt of = case ctxt of
HsBootCtxt -> lookup_top (const True) True HsBootCtxt -> lookup_top (const True) True
TopSigCtxt ns meth_ok -> lookup_top (`elemNameSet` ns) meth_ok TopSigCtxt ns meth_ok -> lookup_top (`elemNameSet` ns) meth_ok
RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns) False
LocalBindCtxt ns -> lookup_group ns LocalBindCtxt ns -> lookup_group ns
ClsDeclCtxt cls -> lookup_cls_op cls ClsDeclCtxt cls -> lookup_cls_op cls
InstDeclCtxt cls -> lookup_cls_op cls InstDeclCtxt cls -> lookup_cls_op cls
......
...@@ -951,7 +951,8 @@ rnTyClDecls :: Maybe FreeVars -> [TyClGroup RdrName] ...@@ -951,7 +951,8 @@ rnTyClDecls :: Maybe FreeVars -> [TyClGroup RdrName]
-- Rename the declarations and do depedency analysis on them -- Rename the declarations and do depedency analysis on them
rnTyClDecls extra_deps tycl_ds rnTyClDecls extra_deps tycl_ds
= do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat 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 ; this_mod <- getModule
; let add_boot_deps :: FreeVars -> FreeVars ; let add_boot_deps :: FreeVars -> FreeVars
-- See Note [Extra dependencies from .hs-boot files] -- See Note [Extra dependencies from .hs-boot files]
...@@ -1094,13 +1095,14 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, ...@@ -1094,13 +1095,14 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
rnTySyn doc rhs = rnLHsType doc rhs 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. -- and checks for duplicate role annotations.
-- It is quite convenient to do both of these in the same place. -- It is quite convenient to do both of these in the same place.
-- See also Note [Role annotations in the renamer] -- See also Note [Role annotations in the renamer]
rnRoleAnnots :: [LRoleAnnotDecl RdrName] rnRoleAnnots :: NameSet -- ^ of the decls in this group
-> [LRoleAnnotDecl RdrName]
-> RnM (NameEnv (LRoleAnnotDecl Name)) -> RnM (NameEnv (LRoleAnnotDecl Name))
rnRoleAnnots role_annots rnRoleAnnots decl_names role_annots
= do { -- check for duplicates *before* renaming, to avoid lumping = do { -- check for duplicates *before* renaming, to avoid lumping
-- together all the unboundNames -- together all the unboundNames
let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
...@@ -1116,8 +1118,11 @@ rnRoleAnnots role_annots ...@@ -1116,8 +1118,11 @@ rnRoleAnnots role_annots
, not (isUnboundName name) ] } , not (isUnboundName name) ] }
where where
rn_role_annot1 (RoleAnnotDecl tycon roles) rn_role_annot1 (RoleAnnotDecl tycon roles)
= do { -- the name is an *occurrence* = do { -- the name is an *occurrence*, but look it up only in the
tycon' <- wrapLocM lookupGlobalOccRn tycon -- decls defined in this group (see #10263)
tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt decl_names)
(text "role annotation")
tycon
; return $ RoleAnnotDecl tycon' roles } ; return $ RoleAnnotDecl tycon' roles }
dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM () dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
......
<interactive>:3:1: <interactive>:3:11: error:
Role annotation for a type previously declared: type role X nominal The role annotation for ‘X’ lacks an accompanying binding
(The role annotation must be given where ‘X’ is declared.) (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']) ...@@ -5,3 +5,4 @@ test('Roles4', only_ways('normal'), compile, ['-ddump-tc'])
test('Roles13', only_ways('normal'), compile, ['-ddump-simpl -dsuppress-uniques']) test('Roles13', only_ways('normal'), compile, ['-ddump-simpl -dsuppress-uniques'])
test('Roles14', only_ways('normal'), compile, ['-ddump-tc']) test('Roles14', only_ways('normal'), compile, ['-ddump-tc'])
test('T8958', [normalise_fun(normalise_errmsg), only_ways('normal')], compile, ['-ddump-tc -dsuppress-uniques']) 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