%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1997
%
\section[RnMonad]{The monad used by the renamer}
#include "HsVersions.h"
module RnMonad(
- RnMonad..,
- SST_R
+ EXP_MODULE(RnMonad),
+ -- close it up (partly done to allow unfoldings)
+ EXP_MODULE(SST),
+ SYN_IE(Module),
+ FiniteMap,
+ Bag,
+ Name,
+ SYN_IE(RdrNameHsDecl),
+ SYN_IE(RdrNameInstDecl),
+ SYN_IE(Version),
+ SYN_IE(NameSet),
+ OccName,
+ Fixity
) where
IMP_Ubiq(){-uitous-}
import SST
-import PreludeGlaST ( SYN_IE(ST), thenST, returnST )
+#if __GLASGOW_HASKELL__ <= 201
+import PreludeGlaST ( SYN_IE(ST), thenStrictlyST, returnStrictlyST )
+#define MkIO
+#else
+import GlaExts
+import IO
+import ST
+import IOBase
+#define IOError13 IOError
+#define MkIO IO
+#endif
import HsSyn
import RdrHsSyn
+import BasicTypes ( SYN_IE(Version), NewOrData )
import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning)
)
-import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet),
+import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet), emptyNameSet,
+ isLocallyDefinedName,
modAndOcc, NamedThing(..)
)
-import CmdLineOpts ( opt_D_show_rn_trace )
+import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas )
import PrelInfo ( builtinNames )
import TyCon ( TyCon {- instance NamedThing -} )
import TysWiredIn ( boolTyCon )
import Pretty
-import PprStyle ( PprStyle(..) )
+import Outputable ( PprStyle(..) )
import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Unique ( Unique )
import FiniteMap ( FiniteMap, emptyFM, bagToFM )
import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
import UniqSet
import Util
+#if __GLASGOW_HASKELL__ >= 202
+import UniqSupply
+#endif
infixr 9 `thenRn`, `thenRn_`
\end{code}
\begin{code}
sstToIO :: SST REAL_WORLD r -> IO r
-sstToIO sst
- = sstToST sst `thenST` \ r ->
- returnST (Right r)
+sstToIO sst =
+ MkIO (
+ sstToST sst `thenStrictlyST` \ r ->
+ returnStrictlyST (Right r))
ioToRnMG :: IO r -> RnMG (Either IOError13 r)
-ioToRnMG io rn_down g_down = stToSST io
+ioToRnMG (MkIO io) rn_down g_down = stToSST io
-traceRn :: Pretty -> RnMG ()
-traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (ppShow 80 msg) >>
+traceRn :: Doc -> RnMG ()
+traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (show msg) >>
hPutStr stderr "\n") `thenRn_`
returnRn ()
| otherwise = returnRn ()
SrcLoc
(MutableVar s RnNameSupply)
(MutableVar s (Bag Warning, Bag Error))
- (MutableVar s [(Name,Necessity)]) -- Occurrences
+ (MutableVar s ([Name],[Name])) -- Occurrences: compulsory and optional resp
data Necessity = Compulsory | Optional -- We *must* find definitions for
-- compulsory occurrences; we *may* find them
-- For renaming source code
data SDown s = SDown
- RnEnv
+ RnEnv -- Global envt
+ NameEnv -- Local name envt (includes global name envt,
+ -- but may shadow it)
Module
RnSMode
-data RnSMode = SourceMode
- | InterfaceMode
+data RnSMode = SourceMode -- Renaming source code
+ | InterfaceMode Necessity -- Renaming interface declarations. The "necessity"
+ -- flag says free variables *must* be found and slurped
+ -- or whether they need not be. For value signatures of
+ -- things that are themselves compulsorily imported
+ -- we arrange that the type signature is read in compulsory mode,
+ -- but the pragmas in optional mode.
-type SearchPath = [String] -- List of directories to seach for interface files
+type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search
+ -- for interface files.
type FreeVars = NameSet
\end{code}
type ModuleAvails = FiniteMap Module Avails
-data AvailInfo = NotAvailable | Avail Name [Name]
+data AvailInfo = NotAvailable
+ | Avail Name -- An ordinary identifier
+ | AvailTC Name -- The name of the type or class
+ [Name] -- The available pieces of type/class. NB: If the type or
+ -- class is itself to be in scope, it must be in this list.
+ -- Thus, typically: AvailTC Eq [Eq, ==, /=]
\end{code}
===================================================
Module -- Name of this module
(FiniteMap Module Version)
(FiniteMap Module (Avails, [(OccName,Fixity)])) -- Exports
- VersionMap
DeclsMap
- (Bag IfaceInst)
+
+ NameSet -- All the names (whether "big" or "small", whether wired-in or not,
+ -- whether locally defined or not) that have been slurped in so far.
+
+ [(Name,Version)] -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that
+ -- have been slurped in so far, with their versions.
+ -- This is used to generate the "usage" information for this module.
+ -- Subset of the previous field.
+
+ (Bag IfaceInst, NameSet) -- The as-yet un-slurped instance decls; this bag is depleted when we
+ -- slurp an instance decl so that we don't slurp the same one twice.
+ -- Together with them is the set of tycons/classes that may allow
+ -- the instance decls in.
+
+ (FiniteMap Name RdrNameTyDecl)
+ -- Deferred data type declarations; each has the following properties
+ -- * it's a data type decl
+ -- * its TyCon is needed
+ -- * the decl may or may not have been slurped, depending on whether any
+ -- of the constrs are needed.
+
[Module] -- Set of modules with "special" instance declarations
-- Excludes this module
-type DeclsMap = FiniteMap Name (AvailInfo, RdrNameHsDecl)
-type VersionMap = FiniteMap Name Version
-type IfaceInst = ([Name], Module, RdrNameInstDecl) -- The Names are those tycons and
- -- classes mentioned by the instance type
+
+type DeclsMap = FiniteMap Name (Version, AvailInfo, RdrNameHsDecl)
+type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl
+ [Name]) -- "Gate" names. Slurp this instance decl when this
+ -- list becomes empty. It's depleted whenever we
+ -- slurp another type or class decl.
\end{code}
initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r
-initRnMS env mod_name mode m rn_down g_down
+initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down
= let
- s_down = SDown env mod_name mode
+ s_down = SDown rn_env name_env mod_name mode
in
m rn_down s_down
emptyIfaces :: Module -> Ifaces
-emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyFM emptyBag []
+emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyNameSet [] (emptyBag, emptyNameSet) emptyFM []
builtins :: FiniteMap (Module,OccName) Name
builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
-- Initial value for the occurrence pool.
-initOccs :: [(Name,Necessity)]
-initOccs = [(getName boolTyCon, Compulsory)]
+initOccs :: ([Name],[Name]) -- Compulsory and optional respectively
+initOccs = ([getName boolTyCon], [])
-- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and
-- rather implausible that not one will be used in the module.
-- We could add some other common types, notably lists, but the general idea is
= runSST (
newMutVarSST name_supply `thenSST` \ names_var ->
newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
- newMutVarSST [] `thenSST` \ occs_var ->
+ newMutVarSST ([],[]) `thenSST` \ occs_var ->
let
rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var
- s_down = SDown emptyRnEnv mod_name InterfaceMode
+ s_down = SDown emptyRnEnv emptyNameEnv mod_name (InterfaceMode Compulsory)
in
m rn_down s_down `thenSST` \ result ->
returnSST result
)
where
- display errs = ppShow 80 (pprBagOfErrors PprDebug errs)
+ display errs = show (pprBagOfErrors PprDebug errs)
{-# INLINE thenRn #-}
{-# INLINE thenRn_ #-}
setNameSupplyRn :: RnNameSupply -> RnM s d ()
setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
= writeMutVarSST names_var names'
+
+-- The "instance-decl unique supply", inst, is just an integer that's used to
+-- give a unique number for each instance declaration.
+newInstUniq :: RnM s d Int
+newInstUniq (RnDown loc names_var errs_var occs_var) l_down
+ = readMutVarSST names_var `thenSST` \ (us, inst, cache) ->
+ writeMutVarSST names_var (us, inst+1, cache) `thenSST_`
+ returnSST inst
\end{code}
================ Occurrences =====================
+Every time we get an occurrence of a name we put it in one of two lists:
+ one for "compulsory" occurrences
+ one for "optional" occurrences
+
+The significance of "compulsory" is
+ (a) we *must* find the declaration
+ (b) in the case of type or class names, the name is part of the
+ source level program, and we must slurp in any instance decls
+ involving it.
+
+We don't need instance decls "optional" names, because the type inference
+process will never come across them. Optional names are buried inside
+type checked (but not renamed) cross-module unfoldings and such.
+
+The pair of lists is held in a mutable variable in RnDown.
+
+The lists are kept separate so that we can process all the compulsory occurrences
+before any of the optional ones. Why? Because suppose we processed an optional
+"g", and slurped an interface decl of g::T->T. Then we'd rename the type T->T in
+optional mode. But if we later need g compulsorily we'll find that it's already
+been slurped and will do nothing. We could, I suppose, rename it a second time,
+but it seems simpler just to do all the compulsory ones first.
+
\begin{code}
-addOccurrenceName :: Necessity -> Name -> RnM s d ()
-addOccurrenceName necessity name (RnDown loc names_var errs_var occs_var) l_down
- = readMutVarSST occs_var `thenSST` \ occs ->
- writeMutVarSST occs_var ((name,necessity) : occs)
+addOccurrenceName :: Name -> RnMS s Name -- Same name returned as passed
+addOccurrenceName name (RnDown loc names_var errs_var occs_var)
+ (SDown rn_env local_env mod_name mode)
+ | isLocallyDefinedName name ||
+ not_necessary necessity
+ = returnSST name
+
+ | otherwise
+ = readMutVarSST occs_var `thenSST` \ (comp_occs, opt_occs) ->
+ let
+ new_occ_pair = case necessity of
+ Optional -> (comp_occs, name:opt_occs)
+ Compulsory -> (name:comp_occs, opt_occs)
+ in
+ writeMutVarSST occs_var new_occ_pair `thenSST_`
+ returnSST name
+ where
+ necessity = case mode of
+ SourceMode -> Compulsory
+ InterfaceMode necessity -> necessity
-addOccurrenceNames :: Necessity -> [Name] -> RnM s d ()
-addOccurrenceNames necessity names (RnDown loc names_var errs_var occs_var) l_down
- = readMutVarSST occs_var `thenSST` \ occs ->
- writeMutVarSST occs_var ([(name,necessity) | name <- names] ++ occs)
-popOccurrenceName :: RnM s d (Maybe (Name,Necessity))
-popOccurrenceName (RnDown loc names_var errs_var occs_var) l_down
+addOccurrenceNames :: [Name] -> RnMS s ()
+addOccurrenceNames names (RnDown loc names_var errs_var occs_var)
+ (SDown rn_env local_env mod_name mode)
+ | not_necessary necessity
+ = returnSST ()
+
+ | otherwise
+ = readMutVarSST occs_var `thenSST` \ (comp_occs, opt_occs) ->
+ let
+ new_occ_pair = case necessity of
+ Optional -> (comp_occs, non_local_names ++ opt_occs)
+ Compulsory -> (non_local_names ++ comp_occs, opt_occs)
+ in
+ writeMutVarSST occs_var new_occ_pair
+ where
+ non_local_names = filter (not . isLocallyDefinedName) names
+ necessity = case mode of
+ SourceMode -> Compulsory
+ InterfaceMode necessity -> necessity
+
+ -- Never look for optional things if we're
+ -- ignoring optional input interface information
+not_necessary Compulsory = False
+not_necessary Optional = opt_IgnoreIfacePragmas
+
+popOccurrenceName :: Necessity -> RnM s d (Maybe Name)
+popOccurrenceName necessity (RnDown loc names_var errs_var occs_var) l_down
= readMutVarSST occs_var `thenSST` \ occs ->
- case occs of
- [] -> returnSST Nothing
- (occ:occs) -> writeMutVarSST occs_var occs `thenSST_`
- returnSST (Just occ)
+ case (necessity, occs) of
+ -- Find a compulsory occurrence
+ (Compulsory, (comp:comps, opts)) -> writeMutVarSST occs_var (comps, opts) `thenSST_`
+ returnSST (Just comp)
+
+ -- Find an optional occurrence
+ -- We shouldn't be looking unless we've done all the compulsories
+ (Optional, (comps, opt:opts)) -> ASSERT( null comps )
+ writeMutVarSST occs_var (comps, opts) `thenSST_`
+ returnSST (Just opt)
+
+ -- No suitable occurrence
+ other -> returnSST Nothing
-- findOccurrencesRn does the enclosed thing with a *fresh* occurrences
-- variable, and returns the list of occurrences thus found. It's useful
findOccurrencesRn :: RnM s d a -> RnM s d [Name]
findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down
- = newMutVarSST [] `thenSST` \ new_occs_var ->
+ = newMutVarSST ([],[]) `thenSST` \ new_occs_var ->
enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down `thenSST_`
- readMutVarSST new_occs_var `thenSST` \ occs ->
- returnSST (map fst occs)
+ readMutVarSST new_occs_var `thenSST` \ (occs,_) ->
+ returnSST occs
\end{code}
================ RnEnv =====================
\begin{code}
+getGlobalNameEnv :: RnMS s NameEnv
+getGlobalNameEnv rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode)
+ = returnSST global_env
+
getNameEnv :: RnMS s NameEnv
-getNameEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
- = returnSST name_env
+getNameEnv rn_down (SDown rn_env local_env mod_name mode)
+ = returnSST local_env
setNameEnv :: NameEnv -> RnMS s a -> RnMS s a
-setNameEnv name_env' m rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
- = m rn_down (SDown (RnEnv name_env' fixity_env) mod_name mode)
+setNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode)
+ = m rn_down (SDown rn_env local_env' mod_name mode)
getFixityEnv :: RnMS s FixityEnv
-getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
+getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode)
= returnSST fixity_env
-
-setRnEnv :: RnEnv -> RnMS s a -> RnMS s a
-setRnEnv rn_env' m rn_down (SDown rn_env mod_name mode)
- = m rn_down (SDown rn_env' mod_name mode)
\end{code}
================ Module and Mode =====================
\begin{code}
getModuleRn :: RnMS s Module
-getModuleRn rn_down (SDown rn_env mod_name mode)
+getModuleRn rn_down (SDown rn_env local_env mod_name mode)
= returnSST mod_name
\end{code}
\begin{code}
getModeRn :: RnMS s RnSMode
-getModeRn rn_down (SDown rn_env mod_name mode)
+getModeRn rn_down (SDown rn_env local_env mod_name mode)
= returnSST mode
+
+setModeRn :: RnSMode -> RnMS s a -> RnMS s a
+setModeRn new_mode thing_inside rn_down (SDown rn_env local_env mod_name mode)
+ = thing_inside rn_down (SDown rn_env local_env mod_name new_mode)
\end{code}
projects / ghc-hetmet.git / blobdiff