[project @ 2002-09-13 15:01:40 by simonpj]

[ghc-hetmet.git] / ghc / compiler / rename / RnMonad.lhs

diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 35a5a56..254b8ec 100644 (file)
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -23,29 +23,20 @@ module RnMonad(
 
 #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, emptyAvailEnv, lookupType,
                          NameSupply(..), 
                          ImportedModuleInfo, WhetherHasOrphans, ImportVersion, 
-                         PersistentRenamerState(..), 
+                         PersistentRenamerState(..),  RdrExportItem,
                          DeclsMap, IfaceInsts, IfaceRules, 
                          HomeSymbolTable, TyThing,
-                         PersistentCompilerState(..), GlobalRdrEnv, LocalRdrEnv,
-                         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
@@ -54,12 +45,19 @@ import RdrName              ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc,
                          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 NameEnv         ( NameEnv, lookupNameEnv, emptyNameEnv, extendNameEnvList )
-import Module          ( Module, ModuleName, ModuleSet, emptyModuleSet,                                    PackageName )
+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 )
@@ -69,8 +67,13 @@ 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}
 
@@ -181,12 +184,7 @@ isCmdLineMode CmdLineMode = True
 isCmdLineMode _ = False
 \end{code}
 
-%===================================================
-\subsubsection{                ENVIRONMENTS}
-%===================================================
-
 \begin{code}
---------------------------------
 type LocalFixityEnv = NameEnv RenamedFixitySig
        -- We keep the whole fixity sig so that we
        -- can report line-number info when there is a duplicate
@@ -194,21 +192,16 @@ type LocalFixityEnv = NameEnv RenamedFixitySig
 
 emptyLocalFixityEnv :: LocalFixityEnv
 emptyLocalFixityEnv = emptyNameEnv
-
-lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity
-lookupLocalFixity env name
-  = case lookupNameEnv env name of 
-       Just (FixitySig _ fix _) -> fix
-       Nothing                  -> defaultFixity
 \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
@@ -221,9 +214,9 @@ data ParsedIface
       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
@@ -232,6 +225,32 @@ data ParsedIface
 
 %************************************************************************
 %*                                                                     *
+\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}
 %*                                                                     *
 %************************************************************************
@@ -704,13 +723,9 @@ getFixityEnv :: RnMS LocalFixityEnv
 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}
 
 %================