[project @ 2005-04-20 13:50:04 by krasimir]

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

diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs
index d907884..6ce921d 100644 (file)
--- a/ghc/compiler/main/GHC.hs
+++ b/ghc/compiler/main/GHC.hs
@@ -36,6 +36,7 @@ module GHC (
        loadMsgs,
        workingDirectoryChanged,
        checkModule, CheckedModule(..),
+       TypecheckedSource, ParsedSource,
 
        -- * Inspecting the module structure of the program
        ModuleGraph, ModSummary(..),
@@ -48,6 +49,8 @@ module GHC (
        getModuleInfo,
        modInfoTyThings,
        modInfoTopLevelScope,
+       modInfoPrintUnqualified,
+       modInfoExports,
        lookupName,
 
        -- * Interactive evaluation
@@ -155,7 +158,7 @@ import DataCon              ( DataCon )
 import Name            ( Name, getName, nameModule_maybe )
 import RdrName         ( RdrName, gre_name, globalRdrEnvElts )
 import NameEnv         ( nameEnvElts )
-import SrcLoc          ( Located(..) )
+import SrcLoc          ( Located(..), mkSrcLoc, srcLocSpan )
 import DriverPipeline
 import DriverPhases    ( Phase(..), isHaskellSrcFilename, startPhase )
 import GetImports      ( getImports )
@@ -179,6 +182,8 @@ import SysTools             ( cleanTempFilesExcept )
 import BasicTypes      ( SuccessFlag(..), succeeded, failed )
 import Maybes          ( orElse, expectJust, mapCatMaybes )
 import TcType           ( tcSplitSigmaTy, isDictTy )
+import Bag             ( unitBag, emptyBag )
+import FastString      ( mkFastString )
 
 import Directory        ( getModificationTime, doesFileExist )
 import Maybe           ( isJust, isNothing, fromJust, fromMaybe, catMaybes )
@@ -652,7 +657,21 @@ checkModule session@(Session ref) mod msg_act = do
    case [ ms | ms <- mg, ms_mod ms == mod ] of
        [] -> return Nothing
        (ms:_) -> do 
-          r <- hscFileCheck hsc_env msg_act ms
+          -- Add in the OPTIONS from the source file This is nasty:
+          -- we've done this once already, in the compilation manager
+          -- It might be better to cache the flags in the
+          -- ml_hspp_file field, say
+          let dflags0 = hsc_dflags hsc_env
+              hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms)
+              opts = getOptionsFromStringBuffer hspp_buf
+          (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts)
+          if (not (null leftovers))
+               then do let filename = fromJust (ml_hs_file (ms_location ms))
+                       msg_act (optionsErrorMsgs leftovers opts filename)
+                       return Nothing
+               else do
+
+          r <- hscFileCheck hsc_env{hsc_dflags=dflags1} msg_act ms
           case r of
                HscFail -> 
                   return Nothing
@@ -872,22 +891,26 @@ upsweep
            HscEnv,             -- With an updated HPT
            [ModSummary])       -- Mods which succeeded
 
-upsweep hsc_env old_hpt stable_mods cleanup msg_act
-     []
+upsweep hsc_env old_hpt stable_mods cleanup msg_act mods
+   = upsweep' hsc_env old_hpt stable_mods cleanup msg_act mods 1 (length mods)
+
+upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+     [] _ _
    = return (Succeeded, hsc_env, [])
 
-upsweep hsc_env old_hpt stable_mods cleanup msg_act
-     (CyclicSCC ms:_)
+upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+     (CyclicSCC ms:_) _ _
    = do putMsg (showSDoc (cyclicModuleErr ms))
         return (Failed, hsc_env, [])
 
-upsweep hsc_env old_hpt stable_mods cleanup msg_act
-     (AcyclicSCC mod:mods)
+upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+     (AcyclicSCC mod:mods) mod_index nmods
    = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ 
        --           show (map (moduleUserString.moduleName.mi_module.hm_iface) 
        --                     (moduleEnvElts (hsc_HPT hsc_env)))
 
         mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods msg_act mod 
+                       mod_index nmods
 
        cleanup         -- Remove unwanted tmp files between compilations
 
@@ -911,8 +934,8 @@ upsweep hsc_env old_hpt stable_mods cleanup msg_act
                               | otherwise = delModuleEnv old_hpt this_mod
 
                ; (restOK, hsc_env2, modOKs) 
-                       <- upsweep hsc_env1 old_hpt1 stable_mods cleanup 
-                               msg_act mods
+                       <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup 
+                               msg_act mods (mod_index+1) nmods
                ; return (restOK, hsc_env2, mod:modOKs)
                }
 
@@ -924,9 +947,11 @@ upsweep_mod :: HscEnv
            -> ([Module],[Module])
            -> (Messages -> IO ())
             -> ModSummary
+            -> Int  -- index of module
+            -> Int  -- total number of modules
             -> IO (Maybe HomeModInfo)  -- Nothing => Failed
 
-upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary
+upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index nmods
    = do 
         let 
            this_mod    = ms_mod summary
@@ -936,7 +961,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary
 
            compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
            compile_it  = upsweep_compile hsc_env old_hpt this_mod 
-                               msg_act summary
+                               msg_act summary mod_index nmods
 
        case ghcMode (hsc_dflags hsc_env) of
            BatchCompile ->
@@ -989,7 +1014,9 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary
                    old_hmi = lookupModuleEnv old_hpt this_mod
 
 -- Run hsc to compile a module
-upsweep_compile hsc_env old_hpt this_mod msg_act summary mb_old_linkable = do
+upsweep_compile hsc_env old_hpt this_mod msg_act summary
+                mod_index nmods
+                mb_old_linkable = do
   let
        -- The old interface is ok if it's in the old HPT 
        --      a) we're compiling a source file, and the old HPT
@@ -1010,6 +1037,7 @@ upsweep_compile hsc_env old_hpt this_mod msg_act summary mb_old_linkable = do
                                     iface = hm_iface hm_info
 
   compresult <- compile hsc_env msg_act summary mb_old_linkable mb_old_iface
+                        mod_index nmods
 
   case compresult of
         -- Compilation failed.  Compile may still have updated the PCS, tho.
@@ -1389,7 +1417,7 @@ preprocessFile dflags src_fn (Just (buf, time))
        let 
            local_opts = getOptionsFromStringBuffer buf
        --
-       (dflags', errs) <- parseDynamicFlags dflags local_opts
+       (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts)
 
        let
            needs_preprocessing
@@ -1402,7 +1430,7 @@ preprocessFile dflags src_fn (Just (buf, time))
        when needs_preprocessing $
           ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
 
-       return (dflags', "<buffer>", buf)
+       return (dflags', src_fn, buf)
 
 
 -----------------------------------------------------------------------------
@@ -1533,6 +1561,9 @@ modInfoTopLevelScope minf
 modInfoExports :: ModuleInfo -> [Name]
 modInfoExports minf = nameSetToList $! (md_exports $! minf_details minf)
 
+modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
+modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf)
+
 isDictonaryId :: Id -> Bool
 isDictonaryId id
   = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }