[project @ 2002-04-01 08:23:30 by simonpj]
[ghc-hetmet.git] / ghc / compiler / main / HscTypes.lhs
index bf85769..1800e84 100644 (file)
@@ -7,7 +7,7 @@
 module HscTypes ( 
        GhciMode(..),
 
-       ModuleLocation(..),
+       ModuleLocation(..), showModMsg,
 
        ModDetails(..), ModIface(..), 
        HomeSymbolTable, emptySymbolTable,
@@ -21,6 +21,7 @@ module HscTypes (
        IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
 
        VersionInfo(..), initialVersionInfo, lookupVersion,
+       FixityEnv, lookupFixity, collectFixities,
 
        TyThing(..), isTyClThing, implicitTyThingIds,
 
@@ -34,6 +35,7 @@ module HscTypes (
        NameSupply(..), OrigNameCache, OrigIParamCache,
        Avails, AvailEnv, emptyAvailEnv,
        GenAvailInfo(..), AvailInfo, RdrAvailInfo, 
+       ExportItem, RdrExportItem,
        PersistentCompilerState(..),
 
        Deprecations(..), lookupDeprec,
@@ -53,36 +55,35 @@ module HscTypes (
 
 #include "HsVersions.h"
 
-import RdrName         ( RdrName, RdrNameEnv, addListToRdrEnv, emptyRdrEnv, 
+import RdrName         ( RdrName, RdrNameEnv, addListToRdrEnv, 
                          mkRdrUnqual, rdrEnvToList )
 import Name            ( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc )
 import NameEnv
 import OccName         ( OccName )
-import Module          ( Module, ModuleName, ModuleEnv,
-                         lookupModuleEnv, lookupModuleEnvByName, emptyModuleEnv
-                       )
+import Module
 import InstEnv         ( InstEnv, ClsInstEnv, DFunId )
 import Rules           ( RuleBase )
 import CoreSyn         ( CoreBind )
 import Id              ( Id )
 import Class           ( Class, classSelIds )
-import TyCon           ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable )
-import DataCon         ( dataConId, dataConWrapId )
+import TyCon           ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons_maybe )
+import DataCon         ( dataConWorkId, dataConWrapId )
 
-import BasicTypes      ( Version, initialVersion, Fixity, IPName )
+import BasicTypes      ( Version, initialVersion, Fixity, defaultFixity, IPName )
 
-import HsSyn           ( DeprecTxt, tyClDeclName, ifaceRuleDeclName )
+import HsSyn           ( DeprecTxt, TyClDecl, tyClDeclName, ifaceRuleDeclName,
+                         tyClDeclNames )
 import RdrHsSyn                ( RdrNameInstDecl, RdrNameRuleDecl, RdrNameTyClDecl )
 import RnHsSyn         ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl )
 
 import CoreSyn         ( IdCoreRule )
 
-import FiniteMap       ( FiniteMap )
+import FiniteMap
 import Bag             ( Bag )
 import Maybes          ( seqMaybe, orElse )
 import Outputable
 import SrcLoc          ( SrcLoc, isGoodSrcLoc )
-import Util            ( thenCmp, sortLt )
+import Util            ( thenCmp, sortLt, unJust )
 import UniqSupply      ( UniqSupply )
 \end{code}
 
@@ -116,6 +117,18 @@ data ModuleLocation
 
 instance Outputable ModuleLocation where
    ppr = text . show
+
+-- Probably doesn't really belong here, but used in HscMain and InteractiveUI.
+
+showModMsg :: Bool -> Module -> ModuleLocation -> String
+showModMsg use_object mod location =
+    mod_str ++ replicate (max 0 (16 - length mod_str)) ' '
+    ++" ( " ++ unJust "showModMsg" (ml_hs_file location) ++ ", "
+    ++ (if use_object
+         then unJust "showModMsg" (ml_obj_file location)
+         else "interpreted")
+    ++ " )"
+ where mod_str = moduleUserString mod
 \end{code}
 
 For a module in another package, the hs_file and obj_file
@@ -145,7 +158,8 @@ the declarations into a single indexed map in the @PersistentRenamerState@.
 \begin{code}
 data ModIface 
    = ModIface {
-        mi_module   :: !Module,                    -- Complete with package info
+        mi_module   :: !Module,
+       mi_package  :: !PackageName,        -- Which package the module comes from
         mi_version  :: !VersionInfo,       -- Module version number
 
         mi_orphan   :: WhetherHasOrphans,   -- Whether this module has orphans
@@ -158,7 +172,7 @@ data ModIface
                -- whether to write a new iface file (changing usages
                -- doesn't affect the version of this module)
 
-        mi_exports  :: ![(ModuleName,Avails)],
+        mi_exports  :: ![ExportItem],
                -- What it exports Kept sorted by (mod,occ), to make
                -- version comparisons easier
 
@@ -166,7 +180,7 @@ data ModIface
                -- Its top level environment or Nothing if we read this
                -- interface from a file.
 
-        mi_fixities :: !(NameEnv Fixity),   -- Fixities
+        mi_fixities :: !FixityEnv,         -- Fixities
        mi_deprecs  :: !Deprecations,       -- Deprecations
 
        mi_decls    :: IfaceDecls           -- The RnDecls form of ModDetails
@@ -236,6 +250,7 @@ data ModDetails
 emptyModIface :: Module -> ModIface
 emptyModIface mod
   = ModIface { mi_module   = mod,
+              mi_package  = preludePackage, -- XXX fully bogus
               mi_version  = initialVersionInfo,
               mi_usages   = [],
               mi_orphan   = False,
@@ -292,10 +307,19 @@ lookupIfaceByModName hit pit mod
 \begin{code}
 data InteractiveContext 
   = InteractiveContext { 
-       ic_module :: Module,            -- The current module in which 
-                                       -- the  user is sitting
+       ic_toplev_scope :: [Module],    -- Include the "top-level" scope of
+                                       -- these modules
+
+       ic_exports :: [Module],         -- Include just the exports of these
+                                       -- modules
+
+       ic_rn_gbl_env :: GlobalRdrEnv,  -- The cached GlobalRdrEnv, built from
+                                       -- ic_toplev_scope and ic_exports
 
-       ic_rn_env :: LocalRdrEnv,       -- Lexical context for variables bound
+       ic_print_unqual :: PrintUnqualified,
+                                       -- cached PrintUnqualified, as above
+
+       ic_rn_local_env :: LocalRdrEnv, -- Lexical context for variables bound
                                        -- during interaction
 
        ic_type_env :: TypeEnv          -- Ditto for types
@@ -349,14 +373,14 @@ implicitTyThingIds things
     go (AClass cl) = classSelIds cl
     go (ATyCon tc) = tyConGenIds tc ++
                     tyConSelIds tc ++
-                    [ n | dc <- tyConDataConsIfAvailable tc, 
+                    [ n | dc <- tyConDataCons_maybe tc `orElse` [],
                           n  <- implicitConIds tc dc]
                -- Synonyms return empty list of constructors and selectors
 
     implicitConIds tc dc       -- Newtypes have a constructor wrapper,
                                -- but no worker
        | isNewTyCon tc = [dataConWrapId dc]
-       | otherwise     = [dataConId dc, dataConWrapId dc]
+       | otherwise     = [dataConWorkId dc, dataConWrapId dc]
 \end{code}
 
 
@@ -455,11 +479,14 @@ data GenAvailInfo name    = Avail name     -- An ordinary identifier
                        deriving( Eq )
                        -- Equality used when deciding if the interface has changed
 
+type RdrExportItem = (ModuleName, [RdrAvailInfo])
+type ExportItem    = (ModuleName, [AvailInfo])
+
 type AvailEnv = NameEnv AvailInfo      -- Maps a Name to the AvailInfo that contains it
 
 emptyAvailEnv :: AvailEnv
 emptyAvailEnv = emptyNameEnv
-                               
+
 instance Outputable n => Outputable (GenAvailInfo n) where
    ppr = pprAvail
 
@@ -471,6 +498,20 @@ pprAvail (AvailTC n ns) = ppr n <> case {- filter (/= n) -} ns of
 pprAvail (Avail n) = ppr n
 \end{code}
 
+\begin{code}
+type FixityEnv = NameEnv Fixity
+
+lookupFixity :: FixityEnv -> Name -> Fixity
+lookupFixity env n = lookupNameEnv env n `orElse` defaultFixity
+
+collectFixities :: FixityEnv -> [TyClDecl Name pat] -> [(Name,Fixity)]
+collectFixities env decls
+  = [ (n, fix) 
+    | d <- decls, (n,_) <- tyClDeclNames d,
+      Just fix <- [lookupNameEnv env n]
+    ]
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *