\section[RnEnv]{Environment manipulation for the renamer monad}
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module RnEnv (
newTopSrcBinder, lookupFamInstDeclBndr,
lookupLocatedBndrRn, lookupBndrRn, lookupBndrRn_maybe,
- lookupLocatedTopBndrRn, lookupTopBndrRn, lookupBndrRn_maybe,
+ lookupLocatedTopBndrRn, lookupTopBndrRn,
lookupLocatedOccRn, lookupOccRn,
lookupLocatedGlobalOccRn, lookupGlobalOccRn,
lookupLocalDataTcNames, lookupSrcOcc_maybe,
- lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn,
+ lookupFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields,
lookupSyntaxName, lookupSyntaxTable, lookupImportedName,
lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
newLocalsRn, newIPNameRn,
bindLocalNames, bindLocalNamesFV,
- MiniFixityEnv, bindLocalNamesFV_WithFixities,
+ MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv,
+ bindLocalNamesFV_WithFixities,
bindLocatedLocalsFV, bindLocatedLocalsRn,
bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
- bindLocalFixities,
checkDupRdrNames, checkDupNames, checkShadowedNames,
checkDupAndShadowedRdrNames,
import LoadIface ( loadInterfaceForName, loadSrcInterface )
import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName )
-import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable,
- LHsTyVarBndr, LHsType,
- Fixity, hsLTyVarLocNames, replaceTyVarName )
+import HsSyn
import RdrHsSyn ( extractHsTyRdrTyVars )
import RdrName
import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity)
consDataConKey, hasKey, forall_tv_RDR )
import UniqSupply
import BasicTypes ( IPName, mapIPName, Fixity )
-import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc,
- srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan )
+import SrcLoc
import Outputable
import Util
import Maybes
Nothing -> returnM Nothing
Just gre -> returnM (Just $ gre_name gre) }
--- lookupLocatedSigOccRn is used for type signatures and pragmas
--- Is this valid?
--- module A
--- import M( f )
--- f :: Int -> Int
--- f x = x
--- It's clear that the 'f' in the signature must refer to A.f
--- The Haskell98 report does not stipulate this, but it will!
--- So we must treat the 'f' in the signature in the same way
--- as the binding occurrence of 'f', using lookupBndrRn
---
--- However, consider this case:
--- import M( f )
--- f :: Int -> Int
--- g x = x
--- 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".
-lookupLocatedSigOccRn :: Located RdrName -> RnM (Located Name)
-lookupLocatedSigOccRn = wrapLocM $ \ rdr_name -> do
- { local_env <- getLocalRdrEnv
- ; case lookupLocalRdrEnv local_env rdr_name of {
- Just n -> return n ;
- Nothing -> do
- { mb_gre <- lookupGreLocalRn rdr_name
- ; case mb_gre of
- Just gre -> return (gre_name gre)
- Nothing -> lookupGlobalOccRn rdr_name
- }}}
-----------------------------------------------
lookupInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name)
-- an instance decl
lookupInstDeclBndr cls rdr = lookup_located_sub_bndr is_op doc rdr
where
- doc = ptext SLIT("method of class") <+> quotes (ppr cls)
- is_op gre@(GRE {gre_par = ParentIs n}) = n == cls
- is_op other = False
+ 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)
; lookup_located_sub_bndr is_field doc rdr_name
}}
where
- doc = ptext SLIT("field of constructor") <+> quotes (ppr data_con)
+ doc = ptext (sLit "field of constructor") <+> quotes (ppr data_con)
lookupConstructorFields :: Name -> RnM [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
= do { addErr (unknownNameErr rdr_name)
; env <- getGlobalRdrEnv;
; traceRn (vcat [unknownNameErr rdr_name,
- ptext SLIT("Global envt is:"),
+ ptext (sLit "Global envt is:"),
nest 3 (pprGlobalRdrEnv env)])
; returnM (mkUnboundName rdr_name) }
| otherwise
= pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name)
where
- doc = ptext SLIT("Need to find") <+> ppr rdr_name
+ doc = ptext (sLit "Need to find") <+> ppr rdr_name
\end{code}
%*********************************************************
%*********************************************************
\begin{code}
-lookupLocalDataTcNames :: RdrName -> RnM [Name]
--- GHC extension: look up both the tycon and data con
--- for con-like things
--- Complain if neither is in scope
-lookupLocalDataTcNames rdr_name
- | Just n <- isExact_maybe rdr_name
- -- Special case for (:), which doesn't get into the GlobalRdrEnv
- = return [n] -- For this we don't need to try the tycon too
- | otherwise
- = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name)
- ; case [gre_name gre | Just gre <- mb_gres] of
- [] -> do {
- -- run for error reporting
- ; unboundName rdr_name
- ; return [] }
- names -> return names
- }
+--------------------------------
+type FastStringEnv a = UniqFM a -- Keyed by FastString
+
+
+emptyFsEnv :: FastStringEnv a
+lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a
+extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a
+
+emptyFsEnv = emptyUFM
+lookupFsEnv = lookupUFM
+extendFsEnv = addToUFM
--------------------------------
-type MiniFixityEnv = OccEnv (Located Fixity)
+type MiniFixityEnv = FastStringEnv (Located Fixity)
-- Mini fixity env for the names we're about
-- to bind, in a single binding group
--
+ -- It is keyed by the *FastString*, not the *OccName*, because
+ -- the single fixity decl infix 3 T
+ -- affects both the data constructor T and the type constrctor T
+ --
-- We keep the location so that if we find
-- a duplicate, we can report it sensibly
-bindLocalFixities :: [FixitySig RdrName] -> (UniqFM (Located Fixity) -> RnM a) -> RnM a
--- Used for nested fixity decls:
--- bind the names that are in scope already;
--- pass the rest to the continuation for later
--- as a FastString->(Located Fixity) map
---
--- No need to worry about type constructors here,
--- Should check for duplicates?
-bindLocalFixities fixes thing_inside
- | null fixes = thing_inside emptyUFM
- | otherwise = do ls <- mappM rn_sig fixes
- let (now, later) = nowAndLater ls
- extendFixityEnv now $ thing_inside later
- where
- rn_sig (FixitySig lv@(L loc v) fix) = do
- vopt <- lookupBndrRn_maybe v
- case vopt of
- Just new_v -> returnM (Left (new_v, (FixItem (rdrNameOcc v) fix)))
- Nothing -> returnM (Right (occNameFS $ rdrNameOcc v, (L loc fix)))
-
- nowAndLater :: [Either (Name, FixItem) (FastString, Located Fixity)]
- -> ([(Name,FixItem)], UniqFM (Located Fixity))
- nowAndLater ls =
- foldr (\ cur -> \ (now, later) ->
- case cur of
- Left (n, f) -> ((n, f) : now, later)
- Right (fs, f) -> (now, addToUFM later fs f))
- ([], emptyUFM) ls
-
+--------------------------------
-- Used for nested fixity decls to bind names along with their fixities.
-- the fixities are given as a UFM from an OccName's FastString to a fixity decl
-- Also check for unused binders
boundFixities = foldr
(\ name -> \ acc ->
-- check whether this name has a fixity decl
- case lookupOccEnv fixities (nameOccName name) of
+ case lookupFsEnv fixities (occNameFS (nameOccName name)) of
Just (L _ fix) -> (name, FixItem (nameOccName name) fix) : acc
Nothing -> acc) [] names
-- bind the names; extend the fixity env; do the thing inside
returnM (mi_fix_fn iface (nameOccName name))
}
where
- doc = ptext SLIT("Checking fixity for") <+> ppr name
+ doc = ptext (sLit "Checking fixity for") <+> ppr name
---------------
lookupTyFixityRn :: Located Name -> RnM Fixity
-lookupTyFixityRn (L loc n) = lookupFixityRn n
+lookupTyFixityRn (L _ n) = lookupFixityRn n
---------------
+lookupLocalDataTcNames :: RdrName -> RnM [Name]
+-- GHC extension: look up both the tycon and data con
+-- for con-like things
+-- Complain if neither is in scope
+lookupLocalDataTcNames rdr_name
+ | Just n <- isExact_maybe rdr_name
+ -- Special case for (:), which doesn't get into the GlobalRdrEnv
+ = return [n] -- For this we don't need to try the tycon too
+ | otherwise
+ = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name)
+ ; case [gre_name gre | Just gre <- mb_gres] of
+ [] -> do {
+ -- run for error reporting
+ ; unboundName rdr_name
+ ; return [] }
+ names -> return names
+ }
+
dataTcOccs :: RdrName -> [RdrName]
-- If the input is a data constructor, return both it and a type
-- constructor. This is useful when we aren't sure which we are
; mappM_ check_shadow loc_rdr_names }
where
check_shadow (loc, occ)
- | Just n <- mb_local = complain [ptext SLIT("bound at") <+> ppr (nameSrcLoc n)]
+ | Just n <- mb_local = complain [ptext (sLit "bound at") <+> ppr (nameSrcLoc n)]
| not (null gres) = complain (map pprNameProvenance gres)
| otherwise = return ()
where
\begin{code}
-- A useful utility
+mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn f xs = mappM f xs `thenM` \ stuff ->
let
(ys, fvs_s) = unzip stuff
= ifOptM Opt_WarnUnusedImports (mappM_ bleat mods)
where
bleat (mod,loc) = addWarnAt loc (mk_warn mod)
- mk_warn m = vcat [ptext SLIT("Module") <+> quotes (ppr m)
+ mk_warn m = vcat [ptext (sLit "Module") <+> quotes (ppr m)
<+> text "is imported, but nothing from it is used,",
- nest 2 (ptext SLIT("except perhaps instances visible in")
+ nest 2 (ptext (sLit "except perhaps instances visible in")
<+> quotes (ppr m)),
- ptext SLIT("To suppress this warning, use:")
- <+> ptext SLIT("import") <+> ppr m <> parens empty ]
+ ptext (sLit "To suppress this warning, use:")
+ <+> ptext (sLit "import") <+> ppr m <> parens empty ]
warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
-------------------------
-- Helpers
+warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
warnUnusedGREs gres
= warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres]
+warnUnusedLocals :: [Name] -> RnM ()
warnUnusedLocals names
= warnUnusedBinds [(n,LocalDef) | n<-names]
warnUnusedName :: (Name, Provenance) -> RnM ()
warnUnusedName (name, LocalDef)
= addUnusedWarning name (srcLocSpan (nameSrcLoc name))
- (ptext SLIT("Defined but not used"))
+ (ptext (sLit "Defined but not used"))
warnUnusedName (name, Imported is)
= mapM_ warn is
where
span = importSpecLoc spec
pp_mod = quotes (ppr (importSpecModule spec))
- msg = ptext SLIT("Imported from") <+> pp_mod <+> ptext SLIT("but not used")
+ msg = ptext (sLit "Imported from") <+> pp_mod <+> ptext (sLit "but not used")
+addUnusedWarning :: Name -> SrcSpan -> SDoc -> RnM ()
addUnusedWarning name span msg
= addWarnAt span $
sep [msg <> colon,
\end{code}
\begin{code}
+addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
addNameClashErrRn rdr_name names
- = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
- ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
+ = addErr (vcat [ptext (sLit "Ambiguous occurrence") <+> quotes (ppr rdr_name),
+ ptext (sLit "It could refer to") <+> vcat (msg1 : msgs)])
where
(np1:nps) = names
- msg1 = ptext SLIT("either") <+> mk_ref np1
- msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps]
+ msg1 = ptext (sLit "either") <+> mk_ref np1
+ msgs = [ptext (sLit " or") <+> mk_ref np | np <- nps]
mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre
+shadowedNameWarn :: SDoc -> OccName -> [SDoc] -> SDoc
shadowedNameWarn doc occ shadowed_locs
- = sep [ptext SLIT("This binding for") <+> quotes (ppr occ)
- <+> ptext SLIT("shadows the existing binding") <> plural shadowed_locs,
+ = sep [ptext (sLit "This binding for") <+> quotes (ppr occ)
+ <+> ptext (sLit "shadows the existing binding") <> plural shadowed_locs,
nest 2 (vcat shadowed_locs)]
$$ doc
+unknownNameErr :: RdrName -> SDoc
unknownNameErr rdr_name
- = vcat [ hang (ptext SLIT("Not in scope:"))
+ = vcat [ hang (ptext (sLit "Not in scope:"))
2 (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
<+> quotes (ppr rdr_name))
, extra ]
where
extra | rdr_name == forall_tv_RDR
- = ptext SLIT("Perhaps you intended to use -XRankNTypes or similar flag")
+ = ptext (sLit "Perhaps you intended to use -XRankNTypes or similar flag")
| otherwise = empty
+unknownSubordinateErr :: SDoc -> RdrName -> SDoc
unknownSubordinateErr doc op -- Doc is "method of class" or
-- "field of constructor"
- = quotes (ppr op) <+> ptext SLIT("is not a (visible)") <+> doc
+ = quotes (ppr op) <+> ptext (sLit "is not a (visible)") <+> doc
+badOrigBinding :: RdrName -> SDoc
badOrigBinding name
- = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name)
+ = ptext (sLit "Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name)
-- The rdrNameOcc is because we don't want to print Prelude.(,)
dupNamesErr :: Outputable n => (n -> SrcSpan) -> SDoc -> [n] -> RnM ()
dupNamesErr get_loc descriptor names
= addErrAt big_loc $
- vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr (head names)),
+ vcat [ptext (sLit "Conflicting definitions for") <+> quotes (ppr (head names)),
locations, descriptor]
where
locs = map get_loc names
big_loc = foldr1 combineSrcSpans locs
one_line = isOneLineSpan big_loc
locations | one_line = empty
- | otherwise = ptext SLIT("Bound at:") <+>
+ | otherwise = ptext (sLit "Bound at:") <+>
vcat (map ppr (sortLe (<=) locs))
+badQualBndrErr :: RdrName -> SDoc
badQualBndrErr rdr_name
- = ptext SLIT("Qualified name in binding position:") <+> ppr rdr_name
+ = ptext (sLit "Qualified name in binding position:") <+> ppr rdr_name
\end{code}
projects / ghc-hetmet.git / blobdiff