Remove comment about imports and exports not being in the renamer result.

[ghc-hetmet.git] / ghc / compiler / main / GHC.hs

diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs
index e278626..d1d1e78 100644 (file)
--- a/ghc/compiler/main/GHC.hs
+++ b/ghc/compiler/main/GHC.hs
@@ -11,7 +11,7 @@ module GHC (
        Session,
        defaultErrorHandler,
        defaultCleanupHandler,
-       init,
+       init, initFromArgs,
        newSession,
 
        -- * Flags and settings
@@ -62,6 +62,7 @@ module GHC (
 #ifdef GHCI
        setContext, getContext, 
        getNamesInScope,
+       getRdrNamesInScope,
        moduleIsInterpreted,
        getInfo,
        exprType,
@@ -83,6 +84,7 @@ module GHC (
        Name, 
        nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
        NamedThing(..),
+       RdrName(Qual,Unqual),
        
        -- ** Identifiers
        Id, idType,
@@ -98,7 +100,7 @@ module GHC (
        TyCon, 
        tyConTyVars, tyConDataCons, tyConArity,
        isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
-       getSynTyConDefn,
+       synTyConDefn, synTyConRhs,
 
        -- ** Type variables
        TyVar,
@@ -176,7 +178,7 @@ import GHC.Exts             ( unsafeCoerce# )
 
 import Packages                ( initPackages )
 import NameSet         ( NameSet, nameSetToList, elemNameSet )
-import RdrName         ( GlobalRdrEnv, GlobalRdrElt(..), RdrName, 
+import RdrName         ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), 
                          globalRdrEnvElts )
 import HsSyn
 import Type            ( Kind, Type, dropForAlls, PredType, ThetaType,
@@ -192,14 +194,14 @@ import Var                ( TyVar )
 import TysPrim         ( alphaTyVars )
 import TyCon           ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
                          isPrimTyCon, isFunTyCon, tyConArity,
-                         tyConTyVars, tyConDataCons, getSynTyConDefn )
+                         tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs )
 import Class           ( Class, classSCTheta, classTvsFds, classMethods )
 import FunDeps         ( pprFundeps )
 import DataCon         ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
                          dataConFieldLabels, dataConStrictMarks, 
                          dataConIsInfix, isVanillaDataCon )
 import Name            ( Name, nameModule, NamedThing(..), nameParent_maybe,
-                         nameSrcLoc )
+                         nameSrcLoc, nameOccName )
 import OccName         ( parenSymOcc )
 import NameEnv         ( nameEnvElts )
 import InstEnv         ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
@@ -306,24 +308,32 @@ defaultCleanupHandler dflags inner =
 
 
 -- | Initialises GHC.  This must be done /once/ only.  Takes the
--- command-line arguments.  All command-line arguments which aren't
--- understood by GHC will be returned.
+-- TopDir path without the '-B' prefix.
 
-init :: [String] -> IO [String]
-init args = do
+init :: Maybe String -> IO ()
+init mbMinusB = do
    -- catch ^C
    main_thread <- myThreadId
    putMVar interruptTargetThread [main_thread]
    installSignalHandlers
 
-   -- Grab the -B option if there is one
-   let (minusB_args, argv1) = partition (prefixMatch "-B") args
-   dflags0 <- initSysTools minusB_args defaultDynFlags
+   dflags0 <- initSysTools mbMinusB defaultDynFlags
    writeIORef v_initDynFlags dflags0
 
-   -- Parse the static flags
-   argv2 <- parseStaticFlags argv1
-   return argv2
+-- | Initialises GHC. This must be done /once/ only. Takes the
+-- command-line arguments.  All command-line arguments which aren't
+-- understood by GHC will be returned.
+
+initFromArgs :: [String] -> IO [String]
+initFromArgs args
+    = do init mbMinusB
+         return argv1
+    where -- Grab the -B option if there is one
+          (minusB_args, argv1) = partition (prefixMatch "-B") args
+          mbMinusB | null minusB_args
+                       = Nothing
+                   | otherwise
+                       = Just (drop 2 (last minusB_args))
 
 GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags)
        -- stores the DynFlags between the call to init and subsequent
@@ -720,13 +730,10 @@ data CheckedModule =
        --  fields within CheckedModule.
 
 type ParsedSource      = Located (HsModule RdrName)
-type RenamedSource     = HsGroup Name
+type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
 type TypecheckedSource = LHsBinds Id
 
 -- NOTE:
---   - things that aren't in the output of the renamer:
---     - the export list
---     - the imports
 --   - things that aren't in the output of the typechecker right now:
 --     - the export list
 --     - the imports
@@ -1887,6 +1894,25 @@ getNamesInScope :: Session -> IO [Name]
 getNamesInScope s = withSession s $ \hsc_env -> do
   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 
+getRdrNamesInScope :: Session -> IO [RdrName]
+getRdrNamesInScope  s = withSession s $ \hsc_env -> do
+  let env = ic_rn_gbl_env (hsc_IC hsc_env)
+  return (concat (map greToRdrNames (globalRdrEnvElts env)))
+
+-- ToDo: move to RdrName
+greToRdrNames :: GlobalRdrElt -> [RdrName]
+greToRdrNames GRE{ gre_name = name, gre_prov = prov }
+  = case prov of
+     LocalDef -> [unqual]
+     Imported specs -> concat (map do_spec (map is_decl specs))
+  where
+    occ = nameOccName name
+    unqual = Unqual occ
+    do_spec decl_spec
+       | is_qual decl_spec = [qual]
+       | otherwise         = [unqual,qual]
+       where qual = Qual (is_as decl_spec) occ
+
 -- | Parses a string as an identifier, and returns the list of 'Name's that
 -- the identifier can refer to in the current interactive context.
 parseName :: Session -> String -> IO [Name]