Session,
defaultErrorHandler,
defaultCleanupHandler,
- init,
+ init, initFromArgs,
newSession,
-- * Flags and settings
import SrcLoc
import DriverPipeline
import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
-import GetImports ( getImports )
+import HeaderInfo ( getImports, getOptions )
import Packages ( isHomePackage )
import Finder
-import HscMain ( newHscEnv, hscFileCheck, HscResult(..) )
+import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
import HscTypes
import DynFlags
-import StaticFlags
import SysTools ( initSysTools, cleanTempFiles )
import Module
import FiniteMap
import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist )
-import Data.Maybe ( isJust, isNothing, fromJust )
+import Data.Maybe ( isJust, isNothing )
import Data.List ( partition, nub )
import qualified Data.List as List
import Control.Monad ( unless, when )
import Data.IORef
import System.IO
import System.IO.Error ( isDoesNotExistError )
-import System.IO.Unsafe ( unsafePerformIO )
import Prelude hiding (init)
#if __GLASGOW_HASKELL__ < 600
-- | 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
-- used to fish out the preprocess output files for the purposes of
-- cleaning up. The preprocessed file *might* be the same as the
-- source file, but that doesn't do any harm.
-ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ]
+ppFilesFromSummaries summaries = map ms_hspp_file summaries
-- -----------------------------------------------------------------------------
-- Check module
-- 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
case [ ms | ms <- mg, ms_mod ms == mod ] of
[] -> return Nothing
(ms:_) -> do
- -- 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)
- filename = fromJust (ml_hs_file (ms_location ms))
- opts = getOptionsFromStringBuffer hspp_buf filename
- (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts)
- if (not (null leftovers))
- then do printErrorsAndWarnings dflags1 (optionsErrorMsgs leftovers opts filename)
- return Nothing
- else do
-
- r <- hscFileCheck hsc_env{hsc_dflags=dflags1} ms
- case r of
- HscFail ->
- return Nothing
- HscChecked parsed renamed Nothing ->
+ mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
+ case mbChecked of
+ Nothing -> return Nothing
+ Just (HscChecked parsed renamed Nothing) ->
return (Just (CheckedModule {
parsedSource = parsed,
renamedSource = renamed,
typecheckedSource = Nothing,
checkedModuleInfo = Nothing }))
- HscChecked parsed renamed
- (Just (tc_binds, rdr_env, details)) -> do
+ Just (HscChecked parsed renamed
+ (Just (tc_binds, rdr_env, details))) -> do
let minf = ModuleInfo {
minf_type_env = md_types details,
minf_exports = md_exports details,
renamedSource = renamed,
typecheckedSource = Just tc_binds,
checkedModuleInfo = Just minf }))
- _other ->
- panic "checkModule"
-- ---------------------------------------------------------------------------
-- Unloading
return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
ms_location = location,
- ms_hspp_file = Just hspp_fn,
+ ms_hspp_file = hspp_fn,
+ ms_hspp_opts = dflags',
ms_hspp_buf = Just buf,
ms_srcimps = srcimps, ms_imps = the_imps,
ms_hs_date = src_timestamp,
findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
findSummaryBySourceFile summaries file
= case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
- fromJust (ml_hs_file (ms_location ms)) == file ] of
+ expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
[] -> Nothing
(x:xs) -> Just x
return (Just ( ModSummary { ms_mod = wanted_mod,
ms_hsc_src = hsc_src,
ms_location = location,
- ms_hspp_file = Just hspp_fn,
+ ms_hspp_file = hspp_fn,
+ ms_hspp_opts = dflags',
ms_hspp_buf = Just buf,
ms_srcimps = srcimps,
ms_imps = the_imps,
= do
-- case we bypass the preprocessing stage?
let
- local_opts = getOptionsFromStringBuffer buf src_fn
+ local_opts = getOptions buf src_fn
--
- (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts)
+ (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts)
let
needs_preprocessing
Nothing -> panic "missing linkable"
Just mod_info -> return (showModMsg obj_linkable mod_summary)
where
- obj_linkable = isObjectLinkable (fromJust (hm_linkable mod_info))
+ obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
#endif /* GHCI */
projects / ghc-hetmet.git / blobdiff