Commit 8f3f4178 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor the way in which type (and other) signatures are renamed

This was a trickier change than I had anticipated, but I think
it's considerably tidier now.

Fixes Trac #5533.
parent 6d5dfbf7
......@@ -727,25 +727,6 @@ isDefaultMethod (SpecPrags {}) = False
\end{code}
\begin{code}
okBindSig :: Sig a -> Bool
okBindSig _ = True
okHsBootSig :: Sig a -> Bool
okHsBootSig (TypeSig _ _) = True
okHsBootSig (GenericSig _ _) = False
okHsBootSig (FixSig _) = True
okHsBootSig _ = False
okClsDclSig :: Sig a -> Bool
okClsDclSig (SpecInstSig _) = False
okClsDclSig _ = True -- All others OK
okInstDclSig :: Sig a -> Bool
okInstDclSig (TypeSig _ _) = False
okInstDclSig (GenericSig _ _) = False
okInstDclSig (FixSig _) = False
okInstDclSig _ = True
isFixityLSig :: LSig name -> Bool
isFixityLSig (L _ (FixSig {})) = True
isFixityLSig _ = False
......
......@@ -11,7 +11,7 @@ they may be affected by renaming (which isn't fully worked out yet).
\begin{code}
module RnBinds (
-- Renaming top-level bindings
rnTopBinds, rnTopBindsLHS, rnTopBindsRHS,
rnTopBindsLHS, rnTopBindsRHS, rnValBindsRHS,
-- Renaming local bindings
rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
......@@ -20,7 +20,7 @@ module RnBinds (
rnMethodBinds, renameSigs, mkSigTvFn,
rnMatchGroup, rnGRHSs,
makeMiniFixityEnv, MiniFixityEnv,
misplacedSigErr
HsSigCtxt(..)
) where
import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
......@@ -169,28 +169,14 @@ rnTopBindsRHS binds
= do { is_boot <- tcIsHsBoot
; if is_boot
then rnTopBindsBoot binds
else rnValBindsRHS Nothing -- Allow SPEC prags for imports
binds }
-- Wrapper if we don't need to do anything in between the left and right,
-- or anything else in the scope of the left
--
-- Never used when there are fixity declarations
rnTopBinds :: HsValBinds RdrName
-> RnM (HsValBinds Name, DefUses)
rnTopBinds b
= do { nl <- rnTopBindsLHS emptyFsEnv b
; let bound_names = collectHsValBinders nl
; bindLocalNames bound_names $
rnValBindsRHS (Just (mkNameSet bound_names)) nl }
else rnValBindsRHS TopSigCtxt binds }
rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
-- A hs-boot file has no bindings.
-- Return a single HsBindGroup with empty binds and renamed signatures
rnTopBindsBoot (ValBindsIn mbinds sigs)
= do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
; sigs' <- renameSigs Nothing okHsBootSig sigs
; sigs' <- renameSigs HsBootCtxt sigs
; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) }
rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b)
\end{code}
......@@ -292,13 +278,12 @@ rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
-- Assumes the LHS vars are in scope
--
-- Does not bind the local fixity declarations
rnValBindsRHS :: Maybe NameSet -- Names bound by the LHSes
-- Nothing if expect sigs for imports
-> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
rnValBindsRHS :: HsSigCtxt
-> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
rnValBindsRHS mb_bound_names (ValBindsIn mbinds sigs)
= do { sigs' <- renameSigs mb_bound_names okBindSig sigs
rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
= do { sigs' <- renameSigs ctxt sigs
; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs')) mbinds
; case depAnalBinds binds_w_dus of
(anal_binds, anal_dus) -> return (valbind', valbind'_dus)
......@@ -322,7 +307,7 @@ rnLocalValBindsRHS :: NameSet -- names bound by the LHSes
-> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
rnLocalValBindsRHS bound_names binds
= rnValBindsRHS (Just bound_names) binds
= rnValBindsRHS (LocalBindCtxt bound_names) binds
-- for local binds
-- wrapper that does both the left- and right-hand sides
......@@ -654,12 +639,11 @@ At the moment we don't gather free-var info from the types in
signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code}
renameSigs :: Maybe NameSet -- If (Just ns) complain if the sig isn't for one of ns
-> (Sig Name -> Bool) -- Complain about the wrong kind of signature if this is False
renameSigs :: HsSigCtxt
-> [LSig RdrName]
-> RnM [LSig Name]
-- Renames the signatures and performs error checks
renameSigs mb_names ok_sig sigs
renameSigs ctxt sigs
= do { mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs) -- Duplicate
-- Check for duplicates on RdrName version,
-- because renamed version has unboundName for
......@@ -670,9 +654,9 @@ renameSigs mb_names ok_sig sigs
-- op :: a -> a
-- default op :: Eq a => a -> a
; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs
; sigs' <- mapM (wrapLocM (renameSig ctxt)) sigs
; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs'
; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
; mapM_ misplacedSigErr bad_sigs -- Misplaced
; return good_sigs }
......@@ -687,19 +671,20 @@ renameSigs mb_names ok_sig sigs
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
renameSig :: Maybe NameSet -> Sig RdrName -> RnM (Sig Name)
renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name)
-- FixitySig is renamed elsewhere.
renameSig _ (IdSig x)
= return (IdSig x) -- Actually this never occurs
renameSig mb_names sig@(TypeSig vs ty)
= do { new_vs <- mapM (lookupSigOccRn mb_names sig) vs
renameSig ctxt sig@(TypeSig vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty
; return (TypeSig new_vs new_ty) }
renameSig mb_names sig@(GenericSig vs ty)
renameSig ctxt sig@(GenericSig vs ty)
= do { defaultSigs_on <- xoptM Opt_DefaultSignatures
; unless defaultSigs_on (addErr (defaultSigErr sig))
; new_v <- mapM (lookupSigOccRn mb_names sig) vs
; new_v <- mapM (lookupSigOccRn ctxt sig) vs
; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty
; return (GenericSig new_v new_ty) }
......@@ -711,23 +696,49 @@ renameSig _ (SpecInstSig ty)
-- so, in the top-level case (when mb_names is Nothing)
-- we use lookupOccRn. If there's both an imported and a local 'f'
-- then the SPECIALISE pragma is ambiguous, unlike all other signatures
renameSig mb_names sig@(SpecSig v ty inl)
= do { new_v <- case mb_names of
Just {} -> lookupSigOccRn mb_names sig v
Nothing -> lookupLocatedOccRn v
renameSig ctxt sig@(SpecSig v ty inl)
= do { new_v <- case ctxt of
TopSigCtxt -> lookupLocatedOccRn v
_ -> lookupSigOccRn ctxt sig v
; new_ty <- rnHsSigType (quotes (ppr v)) ty
; return (SpecSig new_v new_ty inl) }
renameSig mb_names sig@(InlineSig v s)
= do { new_v <- lookupSigOccRn mb_names sig v
renameSig ctxt sig@(InlineSig v s)
= do { new_v <- lookupSigOccRn ctxt sig v
; return (InlineSig new_v s) }
renameSig mb_names sig@(FixSig (FixitySig v f))
= do { new_v <- lookupSigOccRn mb_names sig v
renameSig ctxt sig@(FixSig (FixitySig v f))
= do { new_v <- lookupSigOccRn ctxt sig v
; return (FixSig (FixitySig new_v f)) }
ppr_sig_bndrs :: [Located RdrName] -> SDoc
ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
okHsSig :: HsSigCtxt -> LSig a -> Bool
okHsSig ctxt (L _ sig)
= case (sig, ctxt) of
(GenericSig {}, ClsDeclCtxt {}) -> True
(GenericSig {}, _) -> False
(TypeSig {}, InstDeclCtxt {}) -> False
(TypeSig {}, _) -> True
(FixSig {}, InstDeclCtxt {}) -> False
(FixSig {}, _) -> True
(IdSig {}, TopSigCtxt) -> True
(IdSig {}, _) -> False
(InlineSig {}, HsBootCtxt) -> False
(InlineSig {}, _) -> True
(SpecSig {}, TopSigCtxt) -> True
(SpecSig {}, LocalBindCtxt {}) -> True
(SpecSig {}, InstDeclCtxt {}) -> True
(SpecSig {}, _) -> False
(SpecInstSig {}, InstDeclCtxt {}) -> True
(SpecInstSig {}, _) -> False
\end{code}
......
......@@ -9,7 +9,9 @@ module RnEnv (
lookupLocatedTopBndrRn, lookupTopBndrRn,
lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
lookupLocalDataTcNames, lookupSigOccRn,
HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupSubBndr,
lookupSubBndrGREs, lookupConstructorFields,
......@@ -427,14 +429,16 @@ lookupLocalOccRn_maybe rdr_name
; return (lookupLocalRdrEnv local_env rdr_name) }
-- lookupOccRn looks up an occurrence of a RdrName
lookupOccRn :: RdrName -> RnM Name
lookupOccRn rdr_name
lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)
lookupOccRn_maybe rdr_name
= do { local_env <- getLocalRdrEnv
; case lookupLocalRdrEnv local_env rdr_name of {
Just name -> return name ;
Nothing -> do
; case lookupLocalRdrEnv local_env rdr_name of
Just name -> return (Just name)
Nothing -> lookupGlobalOccRn_maybe rdr_name }
{ mb_name <- lookupGlobalOccRn_maybe rdr_name
lookupOccRn :: RdrName -> RnM Name
lookupOccRn rdr_name
= do { mb_name <- lookupOccRn_maybe rdr_name
; case mb_name of {
Just n -> return n ;
Nothing -> do
......@@ -449,7 +453,7 @@ lookupOccRn rdr_name
; if isQual rdr_name && allow_qual && is_ghci
then lookupQualifiedName rdr_name
else do { traceRn (text "lookupOccRn" <+> ppr rdr_name)
; unboundName WL_Any rdr_name } } } } } }
; unboundName WL_Any rdr_name } } } }
lookupGlobalOccRn :: RdrName -> RnM Name
......@@ -588,67 +592,88 @@ return the imported 'f', so that later on the reanamer will
correctly report "misplaced type sig".
\begin{code}
lookupSigOccRn :: Maybe NameSet -- Just ns => these are the binders
-- in the same group
-- Nothing => signatures without
-- binders are expected
-- (a) top-level (SPECIALISE prags)
-- (b) class decls
-- (c) hs-boot files
data HsSigCtxt
= HsBootCtxt -- Top level of a hs-boot file
| TopSigCtxt -- At top level
| LocalBindCtxt NameSet -- In a local binding, binding these names
| ClsDeclCtxt Name -- Class decl for this class
| InstDeclCtxt Name -- Intsance decl for this class
lookupSigOccRn :: HsSigCtxt
-> Sig RdrName
-> Located RdrName -> RnM (Located Name)
lookupSigOccRn mb_bound_names sig
lookupSigOccRn ctxt sig
= wrapLocM $ \ rdr_name ->
do { mb_name <- lookupBindGroupOcc mb_bound_names (hsSigDoc sig) rdr_name
do { mb_name <- lookupBindGroupOcc ctxt (hsSigDoc sig) rdr_name
; case mb_name of
Left err -> do { addErr err; return (mkUnboundName rdr_name) }
Right name -> return name }
lookupBindGroupOcc :: Maybe NameSet -- See notes on the (Maybe NameSet)
-> SDoc -- in lookupSigOccRn
lookupBindGroupOcc :: HsSigCtxt
-> SDoc
-> RdrName -> RnM (Either Message Name)
-- Looks up the RdrName, expecting it to resolve to one of the
-- bound names passed in. If not, return an appropriate error message
--
-- See Note [Looking up signature names]
lookupBindGroupOcc mb_bound_names what rdr_name
lookupBindGroupOcc ctxt what rdr_name
| Just n <- isExact_maybe rdr_name
= do { n' <- lookupExactOcc n
; check_local_name n' }
; return (Right n') } -- Maybe we should check the side conditions
-- but it's a pain, and Exact things only show
-- up when you know what you are doing
| otherwise
= do { local_env <- getLocalRdrEnv
; case lookupLocalRdrEnv local_env rdr_name of {
Just n -> check_local_name n;
Nothing -> do -- Not defined in a nested scope
{ env <- getGlobalRdrEnv
; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
; case (filter isLocalGRE gres) of
(gre:_) -> check_local_name (gre_name gre)
= 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
where
lookup_cls_op cls
= do { env <- getGlobalRdrEnv
; let gres = lookupSubBndrGREs env (ParentIs cls) rdr_name
; case gres of
[] -> return (Left (unknownSubordinateErr doc rdr_name))
(gre:_) -> return (Right (gre_name gre)) }
-- If there is more than one local GRE for the
-- same OccName 'f', that will be reported separately
-- as a duplicate top-level binding for 'f'
[] | null gres -> bale_out_with empty
| otherwise -> bale_out_with import_msg
}}}
where
check_local_name name -- The name is in scope, and not imported
= case mb_bound_names of
Just bound_names | not (name `elemNameSet` bound_names)
-> bale_out_with local_msg
_other -> return (Right name)
bale_out_with msg
where
doc = ptext (sLit "method of class") <+> quotes (ppr cls)
lookup_top
= 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")))
(gre:_)
| ParentIs {} <- gre_par gre
-> bale_out_with (bad_msg (ptext (sLit "a record selector or class method")))
| otherwise
-> return (Right (gre_name gre)) }
lookup_group bound_names
= do { mb_name <- lookupOccRn_maybe rdr_name
; case mb_name of
Just n
| n `elemNameSet` bound_names -> return (Right n)
| otherwise -> bale_out_with local_msg
Nothing -> bale_out_with empty }
bale_out_with msg
= return (Left (sep [ ptext (sLit "The") <+> what
<+> ptext (sLit "for") <+> quotes (ppr rdr_name)
, nest 2 $ ptext (sLit "lacks an accompanying binding")]
$$ nest 2 msg))
local_msg = parens $ ptext (sLit "The") <+> what <+> ptext (sLit "must be given where")
local_msg = parens $ ptext (sLit "The") <+> what <+> ptext (sLit "must be given where")
<+> quotes (ppr rdr_name) <+> ptext (sLit "is declared")
import_msg = parens $ ptext (sLit "You cannot give a") <+> what
<+> ptext (sLit "for an imported value")
bad_msg thing = parens $ ptext (sLit "You cannot give a") <+> what
<+> ptext (sLit "for") <+> thing
---------------
lookupLocalDataTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name]
......@@ -660,7 +685,7 @@ lookupLocalDataTcNames bndr_set what 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
= do { mb_gres <- mapM (lookupBindGroupOcc (Just bndr_set) what)
= do { mb_gres <- mapM (lookupBindGroupOcc (LocalBindCtxt bndr_set) what)
(dataTcOccs rdr_name)
; let (errs, names) = splitEithers mb_gres
; when (null names) (addErr (head errs)) -- Bleat about one only
......
......@@ -449,9 +449,8 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
--
-- But the (unqualified) method names are in scope
; let binders = collectHsBindsBinders mbinds'
bndr_set = mkNameSet binders
; uprags' <- bindLocalNames binders $
renameSigs (Just bndr_set) okInstDclSig uprags
renameSigs (InstDeclCtxt cls) uprags
; return (InstDecl inst_ty' mbinds' uprags' ats',
meth_fvs `plusFV` at_fvs
......@@ -798,7 +797,7 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
; fds' <- rnFds cls_doc fds
; let rn_at = rnTyClDecl (Just cls')
; (ats', fv_ats) <- mapAndUnzipM (wrapLocFstM rn_at) ats
; sigs' <- renameSigs Nothing okClsDclSig sigs
; sigs' <- renameSigs (ClsDeclCtxt cls') sigs
; (at_defs', fv_at_defs) <- mapAndUnzipM (wrapLocFstM rn_at) at_defs
; let fvs = extractHsCtxtTyNames context' `plusFV`
hsSigsFVs sigs' `plusFV`
......
......@@ -382,8 +382,9 @@ renameDeriv is_boot inst_infos bagBinds
; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
; bindLocalNames (collectHsValBinders rn_aux_lhs) $
do { (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs
; let bndrs = collectHsValBinders rn_aux_lhs
; bindLocalNames bndrs $
do { (rn_aux, dus_aux) <- rnValBindsRHS (LocalBindCtxt (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