From fd0529940130b3991e6bb51d1e2a870e614f829b Mon Sep 17 00:00:00 2001 From: Lemmih Date: Fri, 10 Feb 2006 09:46:01 +0000 Subject: [PATCH] Simplify the -B handling. The interface to the ghc library has changed slightly. --- ghc/compiler/main/GHC.hs | 30 +++++++++++++++++++----------- ghc/compiler/main/Main.hs | 4 ++-- ghc/compiler/main/SysTools.lhs | 36 +++++++++++++++++------------------- 3 files changed, 38 insertions(+), 32 deletions(-) diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 6f6b7c8..85f62f3 100644 --- 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 @@ -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 diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 8d6e30a..ec5a116 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -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 diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index d6ed737..05153ce 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -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 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 option") + Just dir -> return dir \end{code} -- 1.7.10.4