Commit fd052994 authored by David Himmelstrup's avatar David Himmelstrup
Browse files

Simplify the -B handling. The interface to the ghc library has changed slightly.

parent 3c245de9
......@@ -11,7 +11,7 @@ module GHC (
Session,
defaultErrorHandler,
defaultCleanupHandler,
init,
init, initFromArgs,
newSession,
-- * Flags and settings
......@@ -308,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
......
......@@ -31,7 +31,7 @@ import Config ( cProjectVersion, cBooterVersion, cProjectName )
import Packages ( dumpPackages, initPackages )
import DriverPhases ( Phase(..), isSourceFilename, anyHsc,
startPhase, isHaskellSrcFilename )
import StaticFlags ( staticFlags, v_Ld_inputs )
import StaticFlags ( staticFlags, v_Ld_inputs, parseStaticFlags )
import DynFlags ( defaultDynFlags )
import BasicTypes ( failed )
import ErrUtils ( Message, debugTraceMsg, putMsg )
......@@ -65,7 +65,7 @@ main =
GHC.defaultErrorHandler defaultDynFlags $ do
argv0 <- getArgs
argv1 <- GHC.init argv0
argv1 <- parseStaticFlags =<< GHC.initFromArgs argv0
-- 2. Parse the "mode" flags (--make, --interactive etc.)
(cli_mode, argv2) <- parseModeFlags argv1
......
......@@ -198,7 +198,7 @@ getTopDir = readIORef v_TopDir
%************************************************************************
\begin{code}
initSysTools :: [String] -- Command-line arguments starting "-B"
initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
-> DynFlags
-> IO DynFlags -- Set all the mutable variables above, holding
......@@ -207,8 +207,8 @@ initSysTools :: [String] -- Command-line arguments starting "-B"
-- (c) the GHC usage message
initSysTools minusB_args dflags
= do { (am_installed, top_dir) <- findTopDir minusB_args
initSysTools mbMinusB dflags
= do { (am_installed, top_dir) <- findTopDir mbMinusB
; writeIORef v_TopDir top_dir
-- top_dir
-- for "installed" this is the root of GHC's support files
......@@ -399,9 +399,8 @@ foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO
--
-- Plan of action:
-- 1. Set proto_top_dir
-- a) look for (the last) -B flag, and use it
-- b) if there are no -B flags, get the directory
-- where GHC is running (only on Windows)
-- if there is no given TopDir path, get the directory
-- where GHC is running (only on Windows)
--
-- 2. If package.conf exists in proto_top_dir, we are running
-- installed; and TopDir = proto_top_dir
......@@ -412,11 +411,11 @@ foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO
--
-- This is very gruesome indeed
findTopDir :: [String]
-> IO (Bool, -- True <=> am installed, False <=> in-place
String) -- TopDir (in Unix format '/' separated)
findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
-> IO (Bool, -- True <=> am installed, False <=> in-place
String) -- TopDir (in Unix format '/' separated)
findTopDir minusbs
findTopDir mbMinusB
= do { top_dir <- get_proto
-- Discover whether we're running in a build tree or in an installation,
-- by looking for the package configuration file.
......@@ -426,15 +425,14 @@ findTopDir minusbs
}
where
-- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
get_proto | notNull minusbs
= return (normalisePath (drop 2 (last minusbs))) -- 2 for "-B"
| otherwise
= do { maybe_exec_dir <- getBaseDir -- Get directory of executable
; case maybe_exec_dir of -- (only works on Windows;
-- returns Nothing on Unix)
Nothing -> throwDyn (InstallationError "missing -B<dir> option")
Just dir -> return dir
}
get_proto = case mbMinusB of
Just minusb -> return (normalisePath minusb)
Nothing
-> do maybe_exec_dir <- getBaseDir -- Get directory of executable
case maybe_exec_dir of -- (only works on Windows;
-- returns Nothing on Unix)
Nothing -> throwDyn (InstallationError "missing -B<dir> option")
Just dir -> return dir
\end{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment