Commit 11d8f84f authored by Simon Peyton Jones's avatar Simon Peyton Jones

Treat pattern-synonym binders more consistently

Pattern-synonyms are in value declarations, but were being
bound by getLocalNonValBinders.  This seemed odd, and indeed
staightening it out allowed me to remove a field from
TopSigCtxt.

The main changes are in RnSource.rnSrcDecls.

Nice.
parent 2f0011ac
......@@ -780,10 +780,11 @@ hsForeignDeclsBinders foreign_decls
| L decl_loc (ForeignImport (L _ n) _ _ _) <- foreign_decls]
-------------------
hsPatSynBinders :: LHsBindsLR idL idR -> [Located idL]
hsPatSynBinders :: HsValBinds RdrName -> [Located RdrName]
-- Collect pattern-synonym binders only, not Ids
-- See Note [SrcSpan for binders]
hsPatSynBinders binds = foldrBag addPatSynBndr [] binds
hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr [] binds
hsPatSynBinders _ = panic "hsPatSynBinders"
addPatSynBndr :: LHsBindLR idL idR -> [Located idL] -> [Located idL]
-- See Note [SrcSpan for binders]
......
......@@ -176,7 +176,7 @@ rnTopBindsRHS bound_names binds
= do { is_boot <- tcIsHsBootOrSig
; if is_boot
then rnTopBindsBoot binds
else rnValBindsRHS (TopSigCtxt bound_names False) binds }
else rnValBindsRHS (TopSigCtxt bound_names) binds }
rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
-- A hs-boot file has no bindings.
......@@ -442,7 +442,7 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname })
| isTopRecNameMaker name_maker
= do { addLocM checkConName rdrname
; name <- lookupLocatedTopBndrRn rdrname -- Should be bound at top level already
; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already
; return (PatSynBind psb{ psb_id = name }) }
| otherwise -- Pattern synonym, not at top level
......
......@@ -1038,7 +1038,7 @@ correctly report "misplaced type sig".
Note [Signatures for top level things]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
data HsSigCtxt = ... | TopSigCtxt NameSet Bool | ....
data HsSigCtxt = ... | TopSigCtxt NameSet | ....
* The NameSet says what is bound in this group of bindings.
We can't use isLocalGRE from the GlobalRdrEnv, because of this:
......@@ -1049,8 +1049,10 @@ data HsSigCtxt = ... | TopSigCtxt NameSet Bool | ....
will be in the GlobalRdrEnv, and will be a LocalDef. Yet the
signature is mis-placed
* The Bool says whether the signature is ok for a class method
or record selector. Consider
* For type signatures the NameSet should be the names bound by the
value bindings; for fixity declarations, the NameSet should also
include class sigs and record selectors
infix 3 `f` -- Yes, ok
f :: C a => a -> a -- No, not ok
class C a where
......@@ -1058,10 +1060,8 @@ data HsSigCtxt = ... | TopSigCtxt NameSet Bool | ....
-}
data HsSigCtxt
= TopSigCtxt NameSet Bool -- At top level, binding these names
= TopSigCtxt NameSet -- At top level, binding these names
-- See Note [Signatures for top level things]
-- Bool <=> ok to give sig for
-- class method or record selctor
| LocalBindCtxt NameSet -- In a local binding, binding these names
| ClsDeclCtxt Name -- Class decl for this class
| InstDeclCtxt Name -- Intsance decl for this class
......@@ -1107,12 +1107,12 @@ lookupBindGroupOcc ctxt what rdr_name
| otherwise
= 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
HsBootCtxt -> lookup_top (const True)
TopSigCtxt ns -> lookup_top (`elemNameSet` ns)
RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns)
LocalBindCtxt ns -> lookup_group ns
ClsDeclCtxt cls -> lookup_cls_op cls
InstDeclCtxt cls -> lookup_cls_op cls
where
lookup_cls_op cls
= do { env <- getGlobalRdrEnv
......@@ -1126,18 +1126,13 @@ lookupBindGroupOcc ctxt what rdr_name
where
doc = ptext (sLit "method of class") <+> quotes (ppr cls)
lookup_top keep_me meth_ok
lookup_top keep_me
= do { env <- getGlobalRdrEnv
; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
; case filter (keep_me . gre_name) all_gres of
[] | null all_gres -> bale_out_with Outputable.empty
| otherwise -> bale_out_with local_msg
(gre:_)
| ParentIs {} <- gre_par gre
, not meth_ok
-> bale_out_with sub_msg
| otherwise
-> return (Right (gre_name gre)) }
| otherwise -> bale_out_with local_msg
(gre:_) -> return (Right (gre_name gre)) }
lookup_group bound_names -- Look in the local envt (not top level)
= do { local_env <- getLocalRdrEnv
......@@ -1156,9 +1151,6 @@ lookupBindGroupOcc ctxt what rdr_name
local_msg = parens $ ptext (sLit "The") <+> what <+> ptext (sLit "must be given where")
<+> quotes (ppr rdr_name) <+> ptext (sLit "is declared")
sub_msg = parens $ ptext (sLit "You cannot give a") <+> what
<+> ptext (sLit "for a record selector or class method")
---------------
lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [Name]
......
......@@ -526,8 +526,7 @@ getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName
-- * class decls (including class ops)
-- * associated types
-- * foreign imports
-- * pattern synonyms
-- * value signatures (in hs-boot files)
-- * value signatures (in hs-boot files only)
getLocalNonValBinders fixity_env
(HsGroup { hs_valds = binds,
......@@ -551,7 +550,7 @@ getLocalNonValBinders fixity_env
-- type sigs in case of a hs-boot file only
; is_boot <- tcIsHsBootOrSig
; let val_bndrs | is_boot = hs_boot_sig_bndrs
| otherwise = for_hs_bndrs ++ patsyn_hs_bndrs
| otherwise = for_hs_bndrs
; val_avails <- mapM new_simple val_bndrs
; let avails = nti_avails ++ val_avails
......@@ -561,14 +560,11 @@ getLocalNonValBinders fixity_env
; envs <- extendGlobalRdrEnvRn avails fixity_env
; return (envs, new_bndrs) } }
where
ValBindsIn val_binds val_sigs = binds
ValBindsIn _val_binds val_sigs = binds
for_hs_bndrs :: [Located RdrName]
for_hs_bndrs = hsForeignDeclsBinders foreign_decls
patsyn_hs_bndrs :: [Located RdrName]
patsyn_hs_bndrs = hsPatSynBinders val_binds
-- In a hs-boot file, the value binders come from the
-- *signatures*, and there should be no foreign binders
hs_boot_sig_bndrs = [ L decl_loc (unLoc n)
......
......@@ -100,9 +100,6 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
-- because they do not have value declarations.
-- Aso step (C) depends on datacons and record fields
--
-- * Pattern synonyms, because they (and data constructors)
-- are needed for rnTopBindLHS (Trac #9889)
--
-- * For hs-boot files, include the value signatures
-- Again, they have no value declarations
--
......@@ -117,20 +114,25 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
-- scope from (B) above
inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
-- (D) Rename the left-hand sides of the value bindings.
-- (D1) Bring pattern synonyms into scope.
-- Need to do this before (D2) because rnTopBindsLHS
-- looks up those pattern synonyms (Trac #9889)
pat_syn_bndrs <- mapM newTopSrcBinder (hsPatSynBinders val_decls) ;
tc_envs <- extendGlobalRdrEnvRn (map Avail pat_syn_bndrs) local_fix_env ;
setEnvs tc_envs $ do {
-- (D2) Rename the left-hand sides of the value bindings.
-- This depends on everything from (B) being in scope,
-- and on (C) for resolving record wild cards.
-- It uses the fixity env from (A) to bind fixities for view patterns.
new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
-- bind the LHSes (and their fixities) in the global rdr environment
let { val_binders = collectHsIdBinders new_lhs ;
-- Not pattern-synonym binders, because we did
-- them in step (B)
all_bndrs = extendNameSetList tc_bndrs val_binders ;
val_avails = map Avail val_binders } ;
traceRn (text "rnSrcDecls" <+> ppr val_avails) ;
(tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
setEnvs (tcg_env, tcl_env) $ do {
-- Bind the LHSes (and their fixities) in the global rdr environment
let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders
-- They are already in scope
traceRn (text "rnSrcDecls" <+> ppr id_bndrs) ;
tc_envs <- extendGlobalRdrEnvRn (map Avail id_bndrs) local_fix_env ;
setEnvs tc_envs $ do {
-- Now everything is in scope, as the remaining renaming assumes.
......@@ -149,13 +151,15 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
-- (F) Rename Value declarations right-hand sides
traceRn (text "Start rnmono") ;
(rn_val_decls, bind_dus) <- rnTopBindsRHS all_bndrs new_lhs ;
let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
(rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ;
traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
-- (G) Rename Fixity and deprecations
-- Rename fixity declarations and error if we try to
-- fix something from another module (duplicates were checked in (A))
let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
-- Rename deprec decls;
......@@ -214,7 +218,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
traceRn (text "finish rnSrc" <+> ppr rn_group) ;
traceRn (text "finish Dus" <+> ppr src_dus ) ;
return (final_tcg_env, rn_group)
}}}}
}}}}}
-- some utils because we do this a bunch above
-- compute and install the new env
......@@ -271,8 +275,7 @@ rnSrcFixityDecls bndr_set fix_decls
= do fix_decls <- mapM rn_decl fix_decls
return (concat fix_decls)
where
sig_ctxt = TopSigCtxt bndr_set True
-- True <=> can give fixity for class decls and record selectors
sig_ctxt = TopSigCtxt bndr_set
rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
-- GHC extension: look up both the tycon and data con
......@@ -321,8 +324,7 @@ rnSrcWarnDecls bndr_set decls'
where
decls = concatMap (\(L _ d) -> wd_warnings d) decls'
sig_ctxt = TopSigCtxt bndr_set True
-- True <=> Can give deprecations for class ops and record sels
sig_ctxt = TopSigCtxt bndr_set
rn_deprec (Warning rdr_names txt)
-- ensures that the names are defined locally
......
......@@ -523,7 +523,7 @@ renameDeriv is_boot inst_infos bagBinds
; let bndrs = collectHsValBinders rn_aux_lhs
; envs <- extendGlobalRdrEnvRn (map Avail bndrs) emptyFsEnv ;
; setEnvs envs $
do { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs) False) rn_aux_lhs
do { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
; return (listToBag rn_inst_infos, rn_aux,
dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
......
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