#include "HsVersions.h"
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 405
-import IOExts ( fixIO )
-#elif defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 302
-import PrelIOBase ( fixIO ) -- Should be in GlaExts
-#else
-import IOBase ( fixIO )
-#endif
-import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO )
-import IO ( hPutStr, stderr )
-
import HsSyn
import RdrHsSyn
import RnHsSyn ( RenamedFixitySig )
-import HscTypes ( AvailEnv, lookupType,
+import HscTypes ( AvailEnv, emptyAvailEnv, lookupType,
NameSupply(..),
ImportedModuleInfo, WhetherHasOrphans, ImportVersion,
- PersistentRenamerState(..), Avails,
+ PersistentRenamerState(..), RdrExportItem,
DeclsMap, IfaceInsts, IfaceRules,
HomeSymbolTable, TyThing,
- PersistentCompilerState(..), GlobalRdrEnv,
- HomeIfaceTable, PackageIfaceTable,
- RdrAvailInfo )
-import BasicTypes ( Version, defaultFixity )
+ PersistentCompilerState(..), GlobalRdrEnv,
+ LocalRdrEnv,
+ HomeIfaceTable, PackageIfaceTable )
+import BasicTypes ( Version, defaultFixity,
+ Fixity(..), FixityDirection(..) )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
Message, Messages, errorsFound, warningsFound,
printErrorsAndWarnings
RdrNameEnv, emptyRdrEnv, extendRdrEnv,
addListToRdrEnv, rdrEnvToList, rdrEnvElts
)
+import Id ( idName )
+import MkId ( seqId )
import Name ( Name, OccName, NamedThing(..),
- nameOccName,
- decode, mkLocalName, mkKnownKeyGlobal
+ nameOccName, nameRdrName,
+ decode, mkInternalName
)
-import Name ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList )
-import Module ( Module, ModuleName, ModuleSet, emptyModuleSet )
+import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv,
+ extendNameEnvList )
+import Module ( Module, ModuleName, ModuleSet, emptyModuleSet,
+ PackageName, preludePackage )
+import PrelInfo ( ghcPrimExports,
+ cCallableClassDecl, cReturnableClassDecl, assertDecl )
+import PrelNames ( mkUnboundName, gHC_PRIM_Name )
import NameSet
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import SrcLoc ( SrcLoc, generatedSrcLoc, noSrcLoc )
import Unique ( Unique )
import FiniteMap ( FiniteMap )
+import Maybes ( seqMaybe )
import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
import UniqSupply
import Outputable
-import PrelNames ( mkUnboundName )
+import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
+import UNSAFE_IO ( unsafePerformIO )
+import FIX_IO ( fixIO )
+
+import IO ( hPutStr, stderr )
+
infixr 9 `thenRn`, `thenRn_`
\end{code}
(\ err -> panic "ioToRnM_no_fail: the I/O operation failed!")
traceRn :: SDoc -> RnM d ()
-traceRn msg
- = doptRn Opt_D_dump_rn_trace `thenRn` \b ->
- if b then putDocRn msg else returnRn ()
+traceRn msg = ifOptRn Opt_D_dump_rn_trace (putDocRn msg)
traceHiDiffsRn :: SDoc -> RnM d ()
-traceHiDiffsRn msg
- = doptRn Opt_D_dump_hi_diffs `thenRn` \b ->
- if b then putDocRn msg else returnRn ()
+traceHiDiffsRn msg = ifOptRn Opt_D_dump_hi_diffs (putDocRn msg)
putDocRn :: SDoc -> RnM d ()
putDocRn msg = ioToRnM (printErrs alwaysQualify msg) `thenRn_`
rn_genv :: GlobalRdrEnv, -- Top level environment
+ rn_avails :: AvailEnv,
+ -- Top level AvailEnv; contains all the things that
+ -- are nameable in the top-level scope, regardless of
+ -- *how* they can be named (qualified, unqualified...)
+ -- It is used only to map a Class to its class ops, and
+ -- hence to resolve the binders in an instance decl
+
rn_lenv :: LocalRdrEnv, -- Local name envt
-- Does *not* include global name envt; may shadow it
-- Includes both ordinary variables and type variables;
isInterfaceMode InterfaceMode = True
isInterfaceMode _ = False
-\end{code}
-%===================================================
-\subsubsection{ ENVIRONMENTS}
-%===================================================
+isCmdLineMode CmdLineMode = True
+isCmdLineMode _ = False
+\end{code}
\begin{code}
---------------------------------
-type LocalRdrEnv = RdrNameEnv Name
type LocalFixityEnv = NameEnv RenamedFixitySig
-- We keep the whole fixity sig so that we
-- can report line-number info when there is a duplicate
emptyLocalFixityEnv :: LocalFixityEnv
emptyLocalFixityEnv = emptyNameEnv
-
-lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity
-lookupLocalFixity env name
- = case lookupNameEnv env name of
- Just (FixitySig _ fix _) -> fix
- Nothing -> defaultFixity
\end{code}
-\begin{code}
-type ExportAvails = (FiniteMap ModuleName Avails,
- -- Used to figure out "module M" export specifiers
- -- Includes avails only from *unqualified* imports
- -- (see 1.4 Report Section 5.1.1)
- AvailEnv) -- Used to figure out all other export specifiers.
-\end{code}
-
-%===================================================
-\subsubsection{ INTERFACE FILE STUFF}
-%===================================================
+%************************************************************************
+%* *
+\subsection{Interface file stuff}
+%* *
+%************************************************************************
\begin{code}
-type ExportItem = (ModuleName, [RdrAvailInfo])
type IfaceDeprecs = Maybe (Either DeprecTxt [(RdrName,DeprecTxt)])
-- Nothing => NoDeprecs
-- Just (Left t) => DeprecAll
data ParsedIface
= ParsedIface {
- pi_mod :: Module, -- Complete with package info
+ pi_mod :: ModuleName,
+ pi_pkg :: PackageName,
pi_vers :: Version, -- Module version number
pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
pi_usages :: [ImportVersion OccName], -- Usages
- pi_exports :: (Version, [ExportItem]), -- Exports
+ pi_exports :: (Version, [RdrExportItem]), -- Exports
pi_decls :: [(Version, RdrNameTyClDecl)], -- Local definitions
- pi_fixity :: [RdrNameFixitySig], -- Local fixity declarations,
+ pi_fixity :: [(RdrName,Fixity)], -- Local fixity declarations,
pi_insts :: [RdrNameInstDecl], -- Local instance declarations
pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version
pi_deprecs :: IfaceDeprecs -- Deprecations
%************************************************************************
%* *
+\subsection{Wired-in interfaces}
+%* *
+%************************************************************************
+
+\begin{code}
+ghcPrimIface :: ParsedIface
+ghcPrimIface = ParsedIface {
+ pi_mod = gHC_PRIM_Name,
+ pi_pkg = preludePackage,
+ pi_vers = 1,
+ pi_orphan = False,
+ pi_usages = [],
+ pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]),
+ pi_decls = [(1,cCallableClassDecl),
+ (1,cReturnableClassDecl),
+ (1,assertDecl)],
+ pi_fixity = [(nameRdrName (idName seqId), Fixity 0 InfixR)],
+ -- seq is infixr 0
+ pi_insts = [],
+ pi_rules = (1,[]),
+ pi_deprecs = Nothing
+ }
+\end{code}
+
+%************************************************************************
+%* *
\subsection{The renamer state}
%* *
%************************************************************************
iSlurp :: 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.
+ --
+ -- It's used for two things:
+ -- a) To record what we've already slurped, so
+ -- we can no-op if we try to slurp it again
+ -- b) As the 'gates' for importing rules. We import a rule
+ -- if all its LHS free vars have been slurped
iVSlurp :: (ModuleSet, NameSet)
-- The Names are all the (a) non-wired-in
return (new_pcs, (warns, errs), res)
-initRnMS :: GlobalRdrEnv -> LocalFixityEnv -> RnMode
+initRnMS :: GlobalRdrEnv -> AvailEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode
-> RnMS a -> RnM d a
-initRnMS rn_env fixity_env mode thing_inside rn_down g_down
+initRnMS rn_env avails local_env fixity_env mode thing_inside rn_down g_down
-- The fixity_env appears in both the rn_fixenv field
-- and in the HIT. See comments with RnHiFiles.lookupFixityRn
= let
- s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv,
- rn_fixenv = fixity_env, rn_mode = mode }
+ s_down = SDown { rn_genv = rn_env, rn_avails = avails,
+ rn_lenv = local_env, rn_fixenv = fixity_env,
+ rn_mode = mode }
in
thing_inside rn_down s_down
initIfaceRnMS :: Module -> RnMS r -> RnM d r
initIfaceRnMS mod thing_inside
- = initRnMS emptyRdrEnv emptyLocalFixityEnv InterfaceMode $
- setModuleRn mod thing_inside
+ = initRnMS emptyRdrEnv emptyAvailEnv emptyRdrEnv
+ emptyLocalFixityEnv InterfaceMode
+ (setModuleRn mod thing_inside)
\end{code}
@renameDerivedCode@ is used to rename stuff ``out-of-line'';
rn_hit = bogus "rn_hit",
rn_ifaces = bogus "rn_ifaces"
}
- ; let s_down = SDown { rn_mode = InterfaceMode,
+ ; let s_down = SDown { rn_mode = InterfaceMode,
-- So that we can refer to PrelBase.True etc
+ rn_avails = emptyAvailEnv,
rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv,
rn_fixenv = emptyLocalFixityEnv }
where
warn = addShortWarnLocLine loc msg
+tryRn :: RnM d a -> RnM d (Either Messages a)
+tryRn try_this down@(RnDown {rn_errs = errs_var}) l_down
+ = do current_msgs <- readIORef errs_var
+ writeIORef errs_var (emptyBag,emptyBag)
+ a <- try_this down l_down
+ (warns, errs) <- readIORef errs_var
+ writeIORef errs_var current_msgs
+ if (isEmptyBag errs)
+ then return (Right a)
+ else return (Left (warns,errs))
+
+setErrsRn :: Messages -> RnM d ()
+setErrsRn msgs down@(RnDown {rn_errs = errs_var}) l_down
+ = do writeIORef errs_var msgs; return ()
+
addErrRn :: Message -> RnM d ()
addErrRn err = failWithRn () err
doptRn dflag (RnDown { rn_dflags = dflags}) l_down
= return (dopt dflag dflags)
+ifOptRn :: DynFlag -> RnM d a -> RnM d ()
+ifOptRn dflag thing_inside down@(RnDown { rn_dflags = dflags}) l_down
+ | dopt dflag dflags = thing_inside down l_down >> return ()
+ | otherwise = return ()
+
getDOptsRn :: RnM d DynFlags
getDOptsRn (RnDown { rn_dflags = dflags}) l_down
= return dflags
getTypeEnvRn :: RnM d (Name -> Maybe TyThing)
getTypeEnvRn down l_down = return (rn_done down)
+
+extendTypeEnvRn :: NameEnv TyThing -> RnM d a -> RnM d a
+extendTypeEnvRn env inside down l_down
+ = inside down{rn_done=new_rn_done} l_down
+ where new_rn_done = \nm -> lookupNameEnv env nm `seqMaybe` rn_done down nm
\end{code}
%================
getGlobalNameEnv rn_down (SDown {rn_genv = global_env})
= return global_env
+getGlobalAvails :: RnMS AvailEnv
+getGlobalAvails rn_down (SDown {rn_avails = avails})
+ = return avails
+
setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a
setLocalNameEnv local_env' m rn_down l_down
= m rn_down (l_down {rn_lenv = local_env'})
getFixityEnv rn_down (SDown {rn_fixenv = fixity_env})
= return fixity_env
-extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a
-extendFixityEnv fixes enclosed_scope
- rn_down l_down@(SDown {rn_fixenv = fixity_env})
- = let
- new_fixity_env = extendNameEnvList fixity_env fixes
- in
- enclosed_scope rn_down (l_down {rn_fixenv = new_fixity_env})
+setFixityEnv :: LocalFixityEnv -> RnMS a -> RnMS a
+setFixityEnv fixes enclosed_scope rn_down l_down
+ = enclosed_scope rn_down (l_down {rn_fixenv = fixes})
\end{code}
%================