Commit bc188bbd authored by Simon Peyton Jones's avatar Simon Peyton Jones

Tidy up the treatment of signatures (incl fixity)

This fixes Trac #6120.  I've added comments to explain.
Turns out there was another lurking bug, also fixed,
and tested in (an extended version of) th/T2713.
parent 0d9c2e8c
......@@ -170,13 +170,13 @@ rnTopBindsLHS :: MiniFixityEnv
rnTopBindsLHS fix_env binds
= rnValBindsLHS (topRecNameMaker fix_env) binds
rnTopBindsRHS :: HsValBindsLR Name RdrName
rnTopBindsRHS :: NameSet -> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
rnTopBindsRHS binds
rnTopBindsRHS bound_names binds
= do { is_boot <- tcIsHsBoot
; if is_boot
then rnTopBindsBoot binds
else rnValBindsRHS TopSigCtxt binds }
else rnValBindsRHS (TopSigCtxt bound_names False) binds }
rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
-- A hs-boot file has no bindings.
......@@ -696,8 +696,8 @@ renameSig _ (SpecInstSig ty)
-- then the SPECIALISE pragma is ambiguous, unlike all other signatures
renameSig ctxt sig@(SpecSig v ty inl)
= do { new_v <- case ctxt of
TopSigCtxt -> lookupLocatedOccRn v
_ -> lookupSigOccRn ctxt sig v
TopSigCtxt {} -> lookupLocatedOccRn v
_ -> lookupSigOccRn ctxt sig v
; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty
; return (SpecSig new_v new_ty inl, fvs) }
......@@ -723,14 +723,14 @@ okHsSig ctxt (L _ sig)
(FixSig {}, InstDeclCtxt {}) -> False
(FixSig {}, _) -> True
(IdSig {}, TopSigCtxt) -> True
(IdSig {}, TopSigCtxt {}) -> True
(IdSig {}, InstDeclCtxt {}) -> True
(IdSig {}, _) -> False
(InlineSig {}, HsBootCtxt) -> False
(InlineSig {}, _) -> True
(SpecSig {}, TopSigCtxt) -> True
(SpecSig {}, TopSigCtxt {}) -> True
(SpecSig {}, LocalBindCtxt {}) -> True
(SpecSig {}, InstDeclCtxt {}) -> True
(SpecSig {}, _) -> False
......
......@@ -837,13 +837,36 @@ We don't want to say 'f' is out of scope; instead, we want to
return the imported 'f', so that later on the reanamer will
correctly report "misplaced type sig".
Note [Signatures for top level things]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
data HsSigCtxt = ... | TopSigCtxt NameSet Bool | ....
* The NameSet says what is bound in this group of bindings.
We can't use isLocalGRE from the GlobalRdrEnv, because of this:
f x = x
$( ...some TH splice... )
f :: Int -> Int
When we encounter the signature for 'f', the binding for 'f'
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
infix 3 `f` -- Yes, ok
f :: C a => a -> a -- No, not ok
class C a where
f :: a -> a
\begin{code}
data HsSigCtxt
= HsBootCtxt -- Top level of a hs-boot file
| TopSigCtxt -- At top level
= TopSigCtxt NameSet Bool -- 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
| HsBootCtxt -- Top level of a hs-boot file
lookupSigOccRn :: HsSigCtxt
-> Sig RdrName
......@@ -875,11 +898,11 @@ lookupBindGroupOcc ctxt what rdr_name
| otherwise
= case ctxt of
HsBootCtxt -> lookup_top
TopSigCtxt -> lookup_top
LocalBindCtxt ns -> lookup_group ns
ClsDeclCtxt cls -> lookup_cls_op cls
InstDeclCtxt cls -> lookup_cls_op cls
HsBootCtxt -> lookup_top (const True) True
TopSigCtxt ns meth_ok -> lookup_top (`elemNameSet` ns) meth_ok
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
......@@ -893,21 +916,22 @@ lookupBindGroupOcc ctxt what rdr_name
where
doc = ptext (sLit "method of class") <+> quotes (ppr cls)
lookup_top
lookup_top keep_me meth_ok
= do { env <- getGlobalRdrEnv
; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
; case filter isLocalGRE gres of
[] | null gres -> bale_out_with empty
| otherwise -> bale_out_with (bad_msg (ptext (sLit "an imported value")))
; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
; case filter (keep_me . gre_name) all_gres of
[] | null all_gres -> bale_out_with empty
| otherwise -> bale_out_with local_msg
(gre:_)
| ParentIs {} <- gre_par gre
-> bale_out_with (bad_msg (ptext (sLit "a record selector or class method")))
| ParentIs {} <- gre_par gre
, not meth_ok
-> bale_out_with sub_msg
| otherwise
-> return (Right (gre_name gre)) }
lookup_group bound_names
= do { mb_name <- lookupOccRn_maybe rdr_name
; case mb_name of
lookup_group bound_names -- Look in the local envt (not top level)
= do { local_env <- getLocalRdrEnv
; case lookupLocalRdrEnv local_env rdr_name of
Just n
| n `elemNameSet` bound_names -> return (Right n)
| otherwise -> bale_out_with local_msg
......@@ -922,31 +946,31 @@ 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")
bad_msg thing = parens $ ptext (sLit "You cannot give a") <+> what
<+> ptext (sLit "for") <+> thing
sub_msg = parens $ ptext (sLit "You cannot give a") <+> what
<+> ptext (sLit "for a record selector or class method")
---------------
lookupLocalTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name]
lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [Name]
-- GHC extension: look up both the tycon and data con or variable.
-- Used for top-level fixity signatures. Complain if neither is in scope.
-- Used for top-level fixity signatures and deprecations.
-- Complain if neither is in scope.
-- See Note [Fixity signature lookup]
lookupLocalTcNames bndr_set what rdr_name
| Just n <- isExact_maybe rdr_name
-- Special case for (:), which doesn't get into the GlobalRdrEnv
= do { n' <- lookupExactOcc n; return [n'] } -- For this we don't need to try the tycon too
| otherwise
lookupLocalTcNames ctxt what rdr_name
= do { mb_gres <- mapM lookup (dataTcOccs rdr_name)
; let (errs, names) = splitEithers mb_gres
; when (null names) $ addErr (head errs) -- Bleat about one only
; return names }
where
lookup = lookupBindGroupOcc (LocalBindCtxt bndr_set) what
lookup = lookupBindGroupOcc ctxt what
dataTcOccs :: RdrName -> [RdrName]
-- Return both the given name and the same name promoted to the TcClsName
-- namespace. This is useful when we aren't sure which we are looking at.
dataTcOccs rdr_name
| Just n <- isExact_maybe rdr_name
, not (isBuiltInSyntax n) -- See Note [dataTcOccs and Exact Names]
= [rdr_name]
| isDataOcc occ || isVarOcc occ
= [rdr_name, rdr_name_tc]
| otherwise
......@@ -956,6 +980,17 @@ dataTcOccs rdr_name
rdr_name_tc = setRdrNameSpace rdr_name tcName
\end{code}
Note [dataTcOccs and Exact Names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Exact RdrNames can occur in code generated by Template Haskell, and generally
those references are, well, exact, so it's wrong to return the TyClsName too.
But there is an awkward exception for built-in syntax. Example in GHCi
:info []
This parses as the Exact RdrName for nilDataCon, but we also want
the list type constructor.
Note that setRdrNameSpace on an Exact name requires the Name to be External,
which it always is for built in syntax.
%*********************************************************
%* *
......
......@@ -114,9 +114,9 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
-- 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 = collectHsValBinders new_lhs ;
all_bndr_set = addListToNameSet tc_bndrs val_binders ;
val_avails = map Avail val_binders } ;
let { val_binders = collectHsValBinders new_lhs ;
all_bndrs = addListToNameSet tc_bndrs val_binders ;
val_avails = map Avail val_binders } ;
(tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ;
setEnvs (tcg_env, tcl_env) $ do {
......@@ -138,19 +138,19 @@ 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 new_lhs ;
(rn_val_decls, bind_dus) <- rnTopBindsRHS all_bndrs 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))
rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
-- Rename deprec decls;
-- check for duplicates and ensure that deprecated things are defined locally
-- at the moment, we don't keep these around past renaming
rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
-- (H) Rename Everything else
......@@ -260,6 +260,9 @@ 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
rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
-- GHC extension: look up both the tycon and data con
-- for con-like things; hence returning a list
......@@ -268,7 +271,7 @@ rnSrcFixityDecls bndr_set fix_decls
rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
= setSrcSpan name_loc $
-- this lookup will fail if the definition isn't local
do names <- lookupLocalTcNames bndr_set what rdr_name
do names <- lookupLocalTcNames sig_ctxt what rdr_name
return [ L loc (FixitySig (L name_loc name) fixity)
| name <- names ]
what = ptext (sLit "fixity signature")
......@@ -301,9 +304,12 @@ rnSrcWarnDecls bndr_set decls
; pairs_s <- mapM (addLocM rn_deprec) decls
; return (WarnSome ((concat pairs_s))) }
where
sig_ctxt = TopSigCtxt bndr_set True
-- True <=> Can give deprecations for class ops and record sels
rn_deprec (Warning rdr_name txt)
-- ensures that the names are defined locally
= do { names <- lookupLocalTcNames bndr_set what rdr_name
= do { names <- lookupLocalTcNames sig_ctxt what rdr_name
; return [(nameOccName name, txt) | name <- names] }
what = ptext (sLit "deprecation")
......
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