lookupGlobalOccRn, lookupGlobalOccRn_maybe,
lookupLocalDataTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn,
- lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields,
+ lookupInstDeclBndr, lookupLocatedSubBndr, lookupConstructorFields,
lookupSyntaxName, lookupSyntaxTable,
lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
getLookupOccRn, addUsedRdrNames,
- newLocalsRn, newIPNameRn,
- bindLocalNames, bindLocalNamesFV,
+ newLocalBndrRn, newLocalBndrsRn, newIPNameRn,
+ bindLocalName, bindLocalNames, bindLocalNamesFV,
MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv,
bindLocalNamesFV_WithFixities,
bindLocatedLocalsFV, bindLocatedLocalsRn,
mapFvRn, mapFvRnCPS,
warnUnusedMatches, warnUnusedModules, warnUnusedImports,
warnUnusedTopBinds, warnUnusedLocalBinds,
- dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg,
-
- checkM
+ dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg
) where
#include "HsVersions.h"
import OccName
import Module ( Module, ModuleName )
import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE,
- consDataConKey, hasKey, forall_tv_RDR )
-import UniqSupply
+ consDataConKey, forall_tv_RDR )
+import Unique
import BasicTypes
import ErrUtils ( Message )
import SrcLoc
-- XXX
thenM :: Monad a => a b -> (b -> a c) -> a c
thenM = (>>=)
-
-thenM_ :: Monad a => a b -> a c -> a c
-thenM_ = (>>)
-
-returnM :: Monad m => a -> m a
-returnM = return
-
-mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
-mappM = mapM
-
-mappM_ :: (Monad m) => (a -> m b) -> [a] -> m ()
-mappM_ = mapM_
-
-checkM :: Monad m => Bool -> m () -> m ()
-checkM = unless
\end{code}
%*********************************************************
-- data T = (,) Int Int
-- unless we are in GHC.Tup
ASSERT2( isExternalName name, ppr name )
- do { checkM (this_mod == nameModule name)
+ do { unless (this_mod == nameModule name)
(addErrAt loc (badOrigBinding rdr_name))
; return name }
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
- = do { checkM (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
+ = do { unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
(addErrAt loc (badOrigBinding rdr_name))
-- When reading External Core we get Orig names as binders,
-- but they should agree with the module gotten from the monad
--TODO, should pass the whole span
| otherwise
- = do { checkM (not (isQual rdr_name))
+ = do { unless (not (isQual rdr_name))
(addErrAt loc (badQualBndrErr rdr_name))
-- Binders should not be qualified; if they are, and with a different
-- module name, we we get a confusing "M.T is not in scope" error later
lookupTopBndrRn_maybe rdr_name
| Just name <- isExact_maybe rdr_name
- = returnM (Just name)
+ = return (Just name)
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-- This deals with the case of derived bindings, where
let occ = rdrNameOcc rdr_name
; when (isTcOcc occ && isSymOcc occ)
(do { op_ok <- doptM Opt_TypeOperators
- ; checkM op_ok (addErr (opDeclErr rdr_name)) })
+ ; unless op_ok (addErr (opDeclErr rdr_name)) })
; mb_gre <- lookupGreLocalRn rdr_name
; case mb_gre of
- Nothing -> returnM Nothing
- Just gre -> returnM (Just $ gre_name gre) }
+ Nothing -> return Nothing
+ Just gre -> return (Just $ gre_name gre) }
-----------------------------------------------
-- name is only in scope qualified. I.e. even if method op is
-- in scope as M.op, we still allow plain 'op' on the LHS of
-- an instance decl
-lookupInstDeclBndr cls rdr = lookup_located_sub_bndr is_op doc rdr
+lookupInstDeclBndr cls rdr = lookupLocatedSubBndr (ParentIs cls) doc rdr
where
doc = ptext (sLit "method of class") <+> quotes (ppr cls)
- is_op (GRE {gre_par = ParentIs n}) = n == cls
- is_op _ = False
-----------------------------------------------
-lookupRecordBndr :: Maybe (Located Name) -> Located RdrName -> RnM (Located Name)
--- Used for record construction and pattern matching
--- When the -XDisambiguateRecordFields flag is on, take account of the
--- constructor name to disambiguate which field to use; it's just the
--- same as for instance decls
---
--- NB: Consider this:
--- module Foo where { data R = R { fld :: Int } }
--- module Odd where { import Foo; fld x = x { fld = 3 } }
--- Arguably this should work, because the reference to 'fld' is
--- unambiguous because there is only one field id 'fld' in scope.
--- But currently it's rejected.
-lookupRecordBndr Nothing rdr_name
- = lookupLocatedGlobalOccRn rdr_name
-lookupRecordBndr (Just (L _ data_con)) rdr_name
- = do { flag_on <- doptM Opt_DisambiguateRecordFields
- ; if not flag_on
- then lookupLocatedGlobalOccRn rdr_name
- else do {
- fields <- lookupConstructorFields data_con
- ; let is_field gre = gre_name gre `elem` fields
- ; lookup_located_sub_bndr is_field doc rdr_name
- }}
- where
- doc = ptext (sLit "field of constructor") <+> quotes (ppr data_con)
-
-
lookupConstructorFields :: Name -> RnM [Name]
-- Look up the fields of a given constructor
-- * For constructors from this module, use the record field env,
; return (dataConFieldLabels con) } }
-----------------------------------------------
-lookup_located_sub_bndr :: (GlobalRdrElt -> Bool)
+-- Used for record construction and pattern matching
+-- When the -XDisambiguateRecordFields flag is on, take account of the
+-- constructor name to disambiguate which field to use; it's just the
+-- same as for instance decls
+--
+-- NB: Consider this:
+-- module Foo where { data R = R { fld :: Int } }
+-- module Odd where { import Foo; fld x = x { fld = 3 } }
+-- Arguably this should work, because the reference to 'fld' is
+-- unambiguous because there is only one field id 'fld' in scope.
+-- But currently it's rejected.
+
+lookupLocatedSubBndr :: Parent -- NoParent => just look it up as usual
+ -- ParentIs p => use p to disambiguate
-> SDoc -> Located RdrName
-> RnM (Located Name)
-lookup_located_sub_bndr is_good doc rdr_name
- = wrapLocM (lookup_sub_bndr is_good doc) rdr_name
-
-lookup_sub_bndr :: (GlobalRdrElt -> Bool) -> SDoc -> RdrName -> RnM Name
-lookup_sub_bndr is_good doc rdr_name
- | isUnqual rdr_name -- Find all the things the rdr-name maps to
- = do { -- and pick the one with the right parent name
- ; addUsedRdrName rdr_name
+lookupLocatedSubBndr parent doc rdr_name
+ = wrapLocM (lookup_sub_bndr parent doc) rdr_name
+
+lookup_sub_bndr :: Parent -> SDoc -> RdrName -> RnM Name
+lookup_sub_bndr parent doc rdr_name
+ | Just n <- isExact_maybe rdr_name -- This happens in derived code
+ = return n
+
+ | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+ = lookupOrig rdr_mod rdr_occ
+
+ | otherwise -- Find all the things the rdr-name maps to
+ = do { -- and pick the one with the right parent name
; env <- getGlobalRdrEnv
- ; case filter is_good (lookupGlobalRdrEnv env (rdrNameOcc rdr_name)) of
+ ; let gres = (lookupGlobalRdrEnv env (rdrNameOcc rdr_name))
+ ; case pick parent gres of
-- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName!
-- The latter does pickGREs, but we want to allow 'x'
-- even if only 'M.x' is in scope
- [gre] -> return (gre_name gre)
+ [gre] -> do { addUsedRdrName gre rdr_name
+ ; return (gre_name gre) }
[] -> do { addErr (unknownSubordinateErr doc rdr_name)
- ; traceRn (text "RnEnv.lookup_sub_bndr" <+> ppr rdr_name)
+ ; traceRn (text "RnEnv.lookup_sub_bndr" <+> (ppr rdr_name $$ ppr gres))
; return (mkUnboundName rdr_name) }
gres -> do { addNameClashErrRn rdr_name gres
- ; return (gre_name (head gres)) }
- }
+ ; return (gre_name (head gres)) } }
+ where
+ pick NoParent gres -- Normal lookup
+ = pickGREs rdr_name gres
+ pick (ParentIs p) gres -- Disambiguating lookup
+ | isUnqual rdr_name = filter (right_parent p) gres
+ | otherwise = filter (right_parent p) (pickGREs rdr_name gres)
- | otherwise -- Occurs in derived instances, where we just
- -- refer directly to the right method with an Orig
- -- And record fields can be Quals: C { F.f = x }
- = lookupGlobalOccRn rdr_name
+ right_parent p (GRE { gre_par = ParentIs p' }) = p==p'
+ right_parent _ _ = False
newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
lookupOccRn rdr_name
= getLocalRdrEnv `thenM` \ local_env ->
case lookupLocalRdrEnv local_env rdr_name of
- Just name -> returnM name
+ Just name -> return name
Nothing -> lookupGlobalOccRn rdr_name
lookupLocatedGlobalOccRn :: Located RdrName -> RnM (Located Name)
; traceRn (vcat [unknownNameErr rdr_name,
ptext (sLit "Global envt is:"),
nest 3 (pprGlobalRdrEnv env)])
- ; returnM (mkUnboundName rdr_name) }
+ ; return (mkUnboundName rdr_name) }
--------------------------------------------------
-- Lookup in the Global RdrEnv of the module
lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
-- Just look up the RdrName in the GlobalRdrEnv
lookupGreRn_maybe rdr_name
- = do { mGre <- lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name)
- ; case mGre of
- Just gre ->
- case gre_prov gre of
- LocalDef -> return ()
- Imported _ -> addUsedRdrName rdr_name
- Nothing ->
- return ()
- ; return mGre }
-
-addUsedRdrName :: RdrName -> RnM ()
-addUsedRdrName rdr
- = do { env <- getGblEnv
- ; updMutVar (tcg_used_rdrnames env)
- (\s -> Set.insert rdr s) }
-
-addUsedRdrNames :: [RdrName] -> RnM ()
-addUsedRdrNames rdrs
- = do { env <- getGblEnv
- ; updMutVar (tcg_used_rdrnames env)
- (\s -> foldr Set.insert s rdrs) }
+ = lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name)
lookupGreRn :: RdrName -> RnM GlobalRdrElt
-- If not found, add error message, and return a fake GRE
lookupGreRn_help rdr_name lookup
= do { env <- getGlobalRdrEnv
; case lookup env of
- [] -> returnM Nothing
- [gre] -> returnM (Just gre)
+ [] -> return Nothing
+ [gre] -> do { addUsedRdrName gre rdr_name
+ ; return (Just gre) }
gres -> do { addNameClashErrRn rdr_name gres
- ; returnM (Just (head gres)) } }
+ ; return (Just (head gres)) } }
+
+addUsedRdrName :: GlobalRdrElt -> RdrName -> RnM ()
+-- Record usage of imported RdrNames
+addUsedRdrName gre rdr
+ | isLocalGRE gre = return ()
+ | otherwise = do { env <- getGblEnv
+ ; updMutVar (tcg_used_rdrnames env)
+ (\s -> Set.insert rdr s) }
+
+addUsedRdrNames :: [RdrName] -> RnM ()
+-- Record used sub-binders
+-- We don't check for imported-ness here, because it's inconvenient
+-- and not stritly necessary.
+addUsedRdrNames rdrs
+ = do { env <- getGblEnv
+ ; updMutVar (tcg_used_rdrnames env)
+ (\s -> foldr Set.insert s rdrs) }
------------------------------
-- GHCi support
loadInterfaceForName doc name `thenM` \ iface -> do {
traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+>
vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]);
- returnM (mi_fix_fn iface (nameOccName name))
+ return (mi_fix_fn iface (nameOccName name))
}
where
doc = ptext (sLit "Checking fixity for") <+> ppr name
else
-- Get the similarly named thing from the local environment
lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name ->
- returnM (HsVar usr_name, unitFV usr_name)
+ return (HsVar usr_name, unitFV usr_name)
where
- normal_case = returnM (HsVar std_name, emptyFVs)
+ normal_case = return (HsVar std_name, emptyFVs)
lookupSyntaxTable :: [Name] -- Standard names
-> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames
if implicit_prelude then normal_case
else
-- Get the similarly named thing from the local environment
- mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names ->
+ mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names ->
- returnM (std_names `zip` map HsVar usr_names, mkFVs usr_names)
+ return (std_names `zip` map HsVar usr_names, mkFVs usr_names)
where
- normal_case = returnM (std_names `zip` map HsVar std_names, emptyFVs)
+ normal_case = return (std_names `zip` map HsVar std_names, emptyFVs)
\end{code}
%*********************************************************
\begin{code}
-newLocalsRn :: [Located RdrName] -> RnM [Name]
-newLocalsRn rdr_names_w_loc
- = newUniqueSupply `thenM` \ us ->
- returnM (zipWith mk rdr_names_w_loc (uniqsFromSupply us))
- where
- mk (L loc rdr_name) uniq
- | Just name <- isExact_maybe rdr_name = name
- -- This happens in code generated by Template Haskell
- | otherwise = ASSERT2( isUnqual rdr_name, ppr rdr_name )
- -- We only bind unqualified names here
- -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName
- mkInternalName uniq (rdrNameOcc rdr_name) loc
+newLocalBndrRn :: Located RdrName -> RnM Name
+-- Used for non-top-level binders. These should
+-- never be qualified.
+newLocalBndrRn (L loc rdr_name)
+ | Just name <- isExact_maybe rdr_name
+ = return name -- This happens in code generated by Template Haskell
+ -- although I'm not sure why. Perhpas it's the call
+ -- in RnPat.newName LetMk?
+ | otherwise
+ = do { unless (isUnqual rdr_name)
+ (addErrAt loc (badQualBndrErr rdr_name))
+ ; uniq <- newUnique
+ ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
+
+newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
+newLocalBndrsRn = mapM newLocalBndrRn
---------------------
checkDupAndShadowedRdrNames :: SDoc -> [Located RdrName] -> RnM ()
---------------------
bindLocatedLocalsRn :: SDoc -- Documentation string for error message
- -> [Located RdrName]
+ -> [Located RdrName]
-> ([Name] -> RnM a)
-> RnM a
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
- = checkDupAndShadowedRdrNames doc_str rdr_names_w_loc `thenM_`
+ = do { checkDupAndShadowedRdrNames doc_str rdr_names_w_loc
-- Make fresh Names and extend the environment
- newLocalsRn rdr_names_w_loc `thenM` \names ->
- bindLocalNames names (enclosed_scope names)
+ ; names <- newLocalBndrsRn rdr_names_w_loc
+ ; bindLocalNames names (enclosed_scope names) }
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names enclosed_scope
- = getLocalRdrEnv `thenM` \ name_env ->
- setLocalRdrEnv (extendLocalRdrEnv name_env names)
- enclosed_scope
+ = do { name_env <- getLocalRdrEnv
+ ; setLocalRdrEnv (extendLocalRdrEnvList name_env names)
+ enclosed_scope }
+
+bindLocalName :: Name -> RnM a -> RnM a
+bindLocalName name enclosed_scope
+ = do { name_env <- getLocalRdrEnv
+ ; setLocalRdrEnv (extendLocalRdrEnv name_env name)
+ enclosed_scope }
bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV names enclosed_scope
= do { (result, fvs) <- bindLocalNames names enclosed_scope
- ; returnM (result, delListFromNameSet fvs names) }
+ ; return (result, delListFromNameSet fvs names) }
-------------------------------------
bindLocatedLocalsFV doc rdr_names enclosed_scope
= bindLocatedLocalsRn doc rdr_names $ \ names ->
enclosed_scope names `thenM` \ (thing, fvs) ->
- returnM (thing, delListFromNameSet fvs names)
+ return (thing, delListFromNameSet fvs names)
-------------------------------------
bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName]
bindTyVarsRn doc_str tyvar_names enclosed_scope
= bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
do { kind_sigs_ok <- doptM Opt_KindSignatures
- ; checkM (null kinded_tyvars || kind_sigs_ok)
+ ; unless (null kinded_tyvars || kind_sigs_ok)
(mapM_ (addErr . kindSigErr) kinded_tyvars)
; enclosed_scope (zipWith replace tyvar_names names) }
where
bindPatSigTyVarsFV tys thing_inside
= bindPatSigTyVars tys $ \ tvs ->
thing_inside `thenM` \ (result,fvs) ->
- returnM (result, fvs `delListFromNameSet` tvs)
+ return (result, fvs `delListFromNameSet` tvs)
bindSigTyVarsFV :: [Name]
-> RnM (a, FreeVars)
-> RnM ()
checkDupRdrNames doc_str rdr_names_w_loc
= -- Check for duplicated names in a binding group
- mappM_ (dupNamesErr getLoc doc_str) dups
+ mapM_ (dupNamesErr getLoc doc_str) dups
where
(_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
-> RnM ()
checkDupNames doc_str names
= -- Check for duplicated names in a binding group
- mappM_ (dupNamesErr nameSrcSpan doc_str) dups
+ mapM_ (dupNamesErr nameSrcSpan doc_str) dups
where
(_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names
checkShadowedNames doc_str (global_env,local_env) loc_rdr_names
= ifOptM Opt_WarnNameShadowing $
do { traceRn (text "shadow" <+> ppr loc_rdr_names)
- ; mappM_ check_shadow loc_rdr_names }
+ ; mapM_ check_shadow loc_rdr_names }
where
check_shadow (loc, occ)
| startsWithUnderscore occ = return () -- Do not report shadowing for "_x"
\begin{code}
-- A useful utility
mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
-mapFvRn f xs = do stuff <- mappM f xs
+mapFvRn f xs = do stuff <- mapM f xs
case unzip stuff of
- (ys, fvs_s) -> returnM (ys, plusFVs fvs_s)
+ (ys, fvs_s) -> return (ys, plusFVs fvs_s)
-- because some of the rename functions are CPSed:
-- maps the function across the list from left to right;
\begin{code}
warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM ()
warnUnusedModules mods
- = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods)
+ = ifOptM Opt_WarnUnusedImports (mapM_ bleat mods)
where
bleat (mod,loc) = addWarnAt loc (mk_warn mod)
mk_warn m = vcat [ptext (sLit "Module") <+> quotes (ppr m)
= warnUnusedBinds [(n,LocalDef) | n<-names]
warnUnusedBinds :: [(Name,Provenance)] -> RnM ()
-warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names)
+warnUnusedBinds names = mapM_ warnUnusedName (filter reportable names)
where reportable (name,_)
| isWiredInName name = False -- Don't report unused wired-in names
-- Otherwise we get a zillion warnings
projects / ghc-hetmet.git / blobdiff