Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Add a '--ghc-path' option.

Useful for testing with different GHC versions. Also fixes issue #1.
  • Loading branch information...
commit f0236376f80d3b1cd9e665fb0525f3ec186da3ac 1 parent 7ec5fb1
@23Skidoo authored
Showing with 51 additions and 35 deletions.
  1. +39 −25 Main.hs
  2. +9 −7 src/GHC/ParMake/Engine.hs
  3. +3 −3 src/GHC/ParMake/Parse.hs
View
64 Main.hs
@@ -2,6 +2,7 @@ module Main
where
import Control.Monad (liftM, when)
+import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess, exitWith)
@@ -22,6 +23,7 @@ data Args = Args {
printVersion :: Bool,
printUsage :: Bool,
numJobs :: Int,
+ ghcPath :: String,
outputFilename :: Maybe String
} deriving Show
@@ -31,6 +33,7 @@ defaultArgs = Args {
printVersion = False,
printUsage = False,
numJobs = 1,
+ ghcPath = "ghc",
outputFilename = Nothing
}
@@ -41,18 +44,22 @@ parseArgs l = go l defaultArgs
(liftM abs $ maybeRead n)
parseVerbosity n = fromMaybe verbose (maybeRead n >>= intToVerbosity)
- go [] acc = acc
- go ("-V":_) acc = acc { printVersion = True }
- go ("--help":_) acc = acc { printUsage = True }
- go ("-j":n:as) acc = go as $ acc { numJobs = parseNumJobs n }
- go (('-':'j':n:[]):as) acc = go as $ acc { numJobs = parseNumJobs [n] }
- go (('-':'v':n:[]):as) acc = go as $
- acc { verbosity = parseVerbosity [n] }
- go (('-':'v':'v':n:[]):as) acc = go as $
- acc { verbosity = parseVerbosity [n] }
- go ("-v":as) acc = go as $ acc { verbosity = verbose }
- go ("-o":n:as) acc = go as $ acc { outputFilename = Just n }
- go (_:as) acc = go as acc
+ go [] acc = acc
+ go ("-V":_) acc = acc { printVersion = True }
+ go ("--help":_) acc = acc { printUsage = True }
+ go ("-j":n:as) acc = go as $ acc { numJobs = parseNumJobs n }
+ go (('-':'j':n:[]):as) acc = go as $ acc { numJobs = parseNumJobs [n] }
+ go (('-':'v':n:[]):as) acc = go as $
+ acc { verbosity = parseVerbosity [n] }
+ go (('-':'v':'v':n:[]):as) acc = go as $
+ acc { verbosity = parseVerbosity [n] }
+ go ("-v":as) acc = go as $ acc { verbosity = verbose }
+ go ("-o":n:as) acc = go as $ acc { outputFilename = Just n }
+ go ("--ghc-path":p:as) acc = go as $ acc { ghcPath = p }
+ go (a:as) acc
+ | "--ghc-path=" `isPrefixOf` a = let (o,p') = break (== '=') a in
+ go (o:(tail p'):as) acc
+ go (_:as) acc = go as acc
getGhcArgs :: [String] -> ([String],[String])
@@ -78,10 +85,13 @@ getGhcArgs argv = let (as, fs) = getGhcArgs' argv [] []
eatOption (x:xs) as = (xs, x:as)
getGhcArgs' [] as fs = (as, fs)
- -- Options not passed to GHC: -o, -j, -vv.
+ -- Options not passed to GHC: -o, -j, -vv, --ghc-path.
getGhcArgs' ("-j":_:xs) as fs = getGhcArgs' xs as fs
getGhcArgs' ("-o":_:xs) as fs = getGhcArgs' xs as fs
getGhcArgs' (('-':'v':'v':_:[]):xs) as fs = getGhcArgs' xs as fs
+ getGhcArgs' ("--ghc-path":_:xs) as fs = getGhcArgs' xs as fs
+ getGhcArgs' (x:xs) as fs
+ | "--ghc-path=" `isPrefixOf` x = getGhcArgs' xs as fs
getGhcArgs' xs@(('-':_):_) as fs = let (xs', as') = eatOption xs as
in getGhcArgs' xs' as' fs
getGhcArgs' (x:xs) as fs = getGhcArgs' xs as (x:fs)
@@ -91,12 +101,14 @@ usage =
putStr $ "Usage: ghc-parmake [OPTIONS] FILES\n" ++
"A parallel wrapper around 'ghc --make'.\n\n" ++
"Options: \n" ++
- "-j N - Run N jobs in parallel. \n" ++
- "-vv[N] - Set verbosity to N (only for ghc-parmake). " ++
+ "-j N - Run N jobs in parallel. \n" ++
+ "-vv[N] - Set verbosity to N (only for ghc-parmake). " ++
"N is 0-3, default 1.\n" ++
- "-v[N] - Set verbosity to N (both for GHC and ghc-parmake itself). \n" ++
- "--help - Print usage information. \n" ++
- "-V - Print version information. \n" ++
+ "-v[N] - Set verbosity to N " ++
+ "(both for GHC and ghc-parmake itself). \n" ++
+ "--help - Print usage information. \n" ++
+ "-V - Print version information. \n" ++
+ "--ghc-path=PATH - Use PATH as the ghc command. \n" ++
"\nOther options are passed to GHC unmodified.\n"
guessOutputFilename :: Maybe FilePath -> [FilePath] -> FilePath
@@ -104,8 +116,8 @@ guessOutputFilename (Just n) _ = n
guessOutputFilename Nothing [n] = dropExtension n
guessOutputFilename Nothing _ = "a.out"
-noInputFiles :: IO ()
-noInputFiles = hPutStrLn stderr "ghc-parmake: no input files"
+fatal :: String -> IO ()
+fatal msg = hPutStrLn stderr $ "ghc-parmake: " ++ msg
-- Program entry point.
@@ -117,12 +129,13 @@ main =
let v = verbosity $ args
debug' v $ "Parsed args: " ++ show args
- when (printVersion args) $ putStrLn "ghc-parmake 0.1" >> exitSuccess
- when (printUsage args) $ usage >> exitSuccess
- when (null files) $ noInputFiles >> exitFailure
+ when (printVersion args) $ putStrLn "ghc-parmake 0.1" >> exitSuccess
+ when (printUsage args) $ usage >> exitSuccess
+ when (null files) $ fatal "no input files" >> exitFailure
+ when (null $ ghcPath args) $ fatal "ghc path is invalid" >> exitFailure
debug' v "Running ghc -M..."
- deps <- Parse.getModuleDeps ghcArgs files
+ deps <- Parse.getModuleDeps (ghcPath args) ghcArgs files
when (null deps) $ exitFailure
debug' v ("Parsed dependencies:\n" ++ show deps)
@@ -131,5 +144,6 @@ main =
debug' v "Building..."
let ofn = guessOutputFilename (outputFilename args) files
- exitCode <- Engine.compile v plan (numJobs args) ghcArgs files ofn
+ exitCode <- Engine.compile v plan (numJobs args)
+ (ghcPath args) ghcArgs files ofn
exitWith exitCode
View
16 src/GHC/ParMake/Engine.hs
@@ -53,10 +53,11 @@ logThread lch = forever $ do
data WorkerTask = BuildModule Int Target | BuildProgram FilePath [FilePath]
type WorkerChan = Chan WorkerTask
-workerThread :: OutputHooks -> Verbosity -> String -> [String] -> [String]
+workerThread :: OutputHooks -> Verbosity -> String
+ -> FilePath -> [String] -> [FilePath]
-> WorkerChan -> ControlChan
-> IO ()
-workerThread outHooks verbosity totNum ghcArgs files wch cch
+workerThread outHooks verbosity totNum ghcPath ghcArgs files wch cch
= forever $ do
task <- readChan wch
case task of
@@ -72,8 +73,8 @@ workerThread outHooks verbosity totNum ghcArgs files wch cch
runGHC :: [String] -> IO ExitCode
runGHC args =
- do debug outHooks verbosity $ show ("ghc":args)
- runProcess outHooks Nothing "ghc" args
+ do debug outHooks verbosity $ show (ghcPath:args)
+ runProcess outHooks Nothing ghcPath args
onSuccess :: ExitCode -> ControlMessage -> ControlMessage -> IO ()
onSuccess exitCode msgSucc msgFail =
@@ -174,9 +175,10 @@ controlThread p outputFilename cch wch =
else return exitCode
-- | Given a BuildPlan, perform the compilation.
-compile :: Verbosity -> BuildPlan -> Int -> [String] -> [String] -> String
+compile :: Verbosity -> BuildPlan -> Int
+ -> FilePath -> [String] -> [FilePath] -> FilePath
-> IO ExitCode
-compile verbosity plan numJobs ghcArgs files outputFilename =
+compile verbosity plan numJobs ghcPath ghcArgs files outputFilename =
do
-- Init comm. channels
workerChan <- newChan
@@ -188,7 +190,7 @@ compile verbosity plan numJobs ghcArgs files outputFilename =
(\n -> forkIO $ workerThread
(logThreadOutputHooks
(if numJobs == 1 then "" else "[" ++ show n ++ "]") logChan)
- verbosity totNum ghcArgs files workerChan controlChan)
+ verbosity totNum ghcPath ghcArgs files workerChan controlChan)
-- Fork off log thread.
_ <- ($) forkIO $ logThread logChan
View
6 src/GHC/ParMake/Parse.hs
@@ -42,12 +42,12 @@ trimLines ls = [ l | l <- ls, isValidLine l]
-- Interaction with the outside world.
-- Run 'ghc -M' and return dependencies for every module.
-getModuleDeps :: [String] -> [String] -> IO [(String, String)]
-getModuleDeps ghcArgs files =
+getModuleDeps :: FilePath -> [String] -> [FilePath] -> IO [(String, String)]
+getModuleDeps ghcPath ghcArgs files =
withSystemTempDirectory "ghc-parmake" $ \tmpDir -> do
let tmpFile = tmpDir </> "depends.mk"
let ghcArgs' = files ++ ("-M":"-dep-makefile":tmpFile:ghcArgs)
- exitCode <- runProcess defaultOutputHooks Nothing "ghc" ghcArgs'
+ exitCode <- runProcess defaultOutputHooks Nothing ghcPath ghcArgs'
if exitCode == ExitSuccess
then (catMaybes . map parseLine . trimLines . lines) <$>
(openFile tmpFile ReadMode >>= hGetContents)
Please sign in to comment.
Something went wrong with that request. Please try again.