Main.hs 20.2 KB
Newer Older
Ben Gamari's avatar
Ben Gamari committed
1 2 3 4 5 6 7 8
{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}

module Main(main) where

-- Standard libraries
import Control.Concurrent
import Control.Exception
import Control.Monad
Ben Gamari's avatar
Ben Gamari committed
9
import Data.Bifunctor
Ben Gamari's avatar
Ben Gamari committed
10
import Data.Char
Ben Gamari's avatar
Ben Gamari committed
11
import Data.Foldable
Ben Gamari's avatar
Ben Gamari committed
12 13
import Data.List
import Data.Maybe
14
import qualified Data.Map.Strict as M
Ben Gamari's avatar
Ben Gamari committed
15 16
import Data.Time.Clock
import qualified System.Directory as IO
Ben Gamari's avatar
Ben Gamari committed
17
import qualified Data.ByteString.Char8 as BS
Ben Gamari's avatar
Ben Gamari committed
18
import qualified Data.ByteString.Lazy.Char8 as BSL
Ben Gamari's avatar
Ben Gamari committed
19 20 21 22 23 24 25 26 27 28
import System.Exit
import System.Info
import System.IO
import System.Process
import System.Console.CmdArgs

-- Shake - build system
import Development.Shake hiding ((*>))
import Development.Shake.FilePath hiding (exe)

Ben Gamari's avatar
Ben Gamari committed
29
import qualified MeasurementTree as MTree
Ben Gamari's avatar
Ben Gamari committed
30
import MeasurementTree (Measurements, Label(..))
Ben Gamari's avatar
Ben Gamari committed
31 32
import qualified ParseResults
import qualified CachegrindParse
Ben Gamari's avatar
Ben Gamari committed
33

Ben Gamari's avatar
Ben Gamari committed
34 35
ml = MTree.mkLabel

Ben Gamari's avatar
Ben Gamari committed
36 37 38 39 40 41 42 43 44 45 46 47 48 49 50
---------------------------------------------------------------------
-- TEST CONFIGURATION - which tests are available to run

-- | These are directories that contain tests.
testRoots :: [String]
testRoots = words "imaginary spectral real parallel spectral/hartel"


-- | These are tests that are under testRoots, but should be skipped (all are skipped by the Makefile system)
disabledTests :: [String]
disabledTests = words "hartel last-piece secretary triangle ebnf2ps HMMS PolyGP rx cfd dcbm linsolv warshall"


-- | These tests are compiled by the Makefile system, but don't work for me (mostly GHC 7.4 breaks)
newlyDisabledTests :: [String]
Ben Gamari's avatar
SHake  
Ben Gamari committed
51
newlyDisabledTests = words "power lift fulsom fluid eff"
Ben Gamari's avatar
Ben Gamari committed
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76


-- | Directories containing tests that the system can run.
allTests :: IO [FilePath]
allTests = do
    xs <- forM testRoots $ \x -> do
        ys <- IO.getDirectoryContents x
        return [x </> y | y <- ys, '.' `notElem` y, y `notElem` disabledTests, y `notElem` newlyDisabledTests]
    fmap sort $ flip filterM (concat xs) $ \x -> do
        b <- IO.doesDirectoryExist x
        if not b then return False else
            IO.doesFileExist $ x </> "Makefile"


---------------------------------------------------------------------
-- ARGUMENT PARSING - mostly based on CmdArgs

data Nofib
    = Clean
    | Build
        {clean :: Bool
        ,tests :: [String]
        ,way :: [String]
        ,threads :: Int
        ,compiler :: String
77
        ,compiler_args :: String
Ben Gamari's avatar
Ben Gamari committed
78 79
        ,tag :: String
        ,output :: String
Ben Gamari's avatar
Ben Gamari committed
80
        ,cachegrind :: Bool
81
        ,cachegrind_args :: String
Ben Gamari's avatar
Ben Gamari committed
82 83
        ,run :: Bool
        ,speed :: Speed
84
        ,rts_args :: [String]
Ben Gamari's avatar
Ben Gamari committed
85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103
        ,times :: Int
        ,skip_check :: Bool
        }
    deriving (Data, Show)

data Speed = Fast | Norm | Slow
    deriving (Data, Show)


nofibMode :: Mode (CmdArgs Nofib)
nofibMode = cmdArgsMode $ modes
    [Clean
        &= help "Clean the build"
    ,Build
        {clean = False &= groupname "Building" &= help "Clean before building"
        ,tests = [] &= args &= typ "TEST"
        ,way = [] &= help "Which way to build, defaults to -O1"
        ,threads = 1 &= name "j" &= typ "NUM" &= help "Number of threads, defaults to 1"
        ,compiler = "ghc" &= help "Compiler to use, defaults to ghc"
104
        ,compiler_args = "" &= help "Extra arguments to pass to the Compiler when building tests"
Ben Gamari's avatar
Ben Gamari committed
105 106
        ,tag = "" &= help "Tag to name the compiler, defaults to compiler --version"
        ,output = "" &= help "Where to put created files under _make, defaults to tag/way"
107 108
        ,cachegrind = False &= groupname "Running" &= help "Run the tests under cachegrind"
        ,cachegrind_args = "" &= groupname "Running" &= help "Extra arguments to pass to cachegrind"
Ben Gamari's avatar
Ben Gamari committed
109 110
        ,run = False &= groupname "Running" &= help "Run the tests"
        ,speed = Norm &= groupname "Running" &= help "Test speed (Fast,Norm,Slow)"
Ben Gamari's avatar
Ben Gamari committed
111
        ,times = 1 &= help "Number of times to run each test"
112
        ,rts_args = [] &= help "Which RTS options to pass when running"
Ben Gamari's avatar
Ben Gamari committed
113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172
        ,skip_check = False &= help "Skip checking the results of the tests"
        } &= auto &= help "Build"
        &= help "Build and run"
    ]
    &= summary "Nofib benchmark suite"


-- | Create a clean set of arguments, with any defaults filled in
nofibArgs :: IO Nofib
nofibArgs = do
    args <- cmdArgsRun nofibMode
    case args of
        Clean -> return args
        Build{..} -> do
            way <- return $ let xs = concatMap words way in if null xs then ["-O1"] else xs
            tag <- if tag == "" then compilerTag compiler else return tag
            tests <- resolveTests tests
            output <- return $ "_make" </> (if null output then tag </> intercalate "_" way else output)
            return Build{..}


-- | Given the tests the user asked for, expand them out, e.g. real is the full real suite.
resolveTests :: [String] -> IO [String]
resolveTests [] = allTests
resolveTests finds = do
    let slash1 x = "/" ++ map (\i -> if i == '\\' then '/' else i) x
        slash2 x = slash1 x ++ "/"
    tests <- allTests
    let whole = filter (\test -> any (\find -> slash2 find `isInfixOf` slash2 test) finds) tests -- whole matches
    let prefix = filter (\test -> any (\find -> slash1 find `isInfixOf` slash2 test) finds) tests -- prefix matches
    let res = if null whole then prefix else whole
    when (null res) $
        error $ "The targets failed to match any programs: " ++ unwords finds
    return res


-- | Find the default compiler string, e.g. ghc-7.4.1
compilerTag :: String -> IO String
compilerTag compiler = do
    (_,stdout,_) <- readProcessWithExitCode compiler ["--version"] ""
    let ver = takeWhile (\x -> isDigit x || x == '.') $ dropWhile (not . isDigit) stdout
    return $ if null ver then "unknown" else ver


---------------------------------------------------------------------
-- MAIN DRIVER

-- | Main program, just interpret the arguments and dispatch the tasks.
main = do
    args <- nofibArgs
    case args of
        Clean -> removeDirectoryRecursive "_make"
        Build{..} -> do
            when clean $
                removeDirectoryRecursive output

            shake shakeOptions
                {shakeThreads=threads
                ,shakeFiles=output ++ "/"
                ,shakeReport=[output ++ "/shake_report.html"]
Ben Gamari's avatar
Ben Gamari committed
173
                ,shakeStaunch=True
Ben Gamari's avatar
Ben Gamari committed
174 175 176 177
                ,shakeVerbosity=Development.Shake.Loud} $
                    buildRules args
            putStrLn "Build completed"

Ben Gamari's avatar
Ben Gamari committed
178
            when run $ do
Ben Gamari's avatar
Ben Gamari committed
179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201
                ns <- mapM (runTest args) tests
                let tot = length ns
                    bad = length $ filter not ns
                    t i = if i == 1 then "1 test" else show i ++ " tests"
                if bad == 0 then
                    putStrLn $ "Ran " ++ t tot ++ " successfully"
                 else
                    putStrLn $ "WARNING: " ++ t bad ++ " failed, out of " ++ t tot


-- | Rules to build the given tests. For each test, there are three files
--   we care about:
--
-- * config.txt - a cleaned up version of the configuration out of Makefile,
--   created by convertConfig. Also contains "MAIN" which points at the name
--   of the Main module.
-- 
-- * Main.exe - the actual binary, produced by ghc linking everything.
--
-- * Main.deps - the files that Main.exe depends on, ghc -M.
--
-- * .hi/.o - files produced by ghc -c.
--
Ben Gamari's avatar
Ben Gamari committed
202 203
-- * .result - the stdout and stderr output from the build
--
Ben Gamari's avatar
Ben Gamari committed
204 205 206
--   Most complication comes from modules not named Main, which still produce
--   Main.o object files (I think ghc -M gets these wrong).
buildRules :: Nofib -> Rules ()
Ben Gamari's avatar
Ben Gamari committed
207
buildRules nofib@Build{..} = do
Ben Gamari's avatar
Ben Gamari committed
208 209 210 211 212 213
    r <- newResource "ghc linker" 1
    let unoutput x =
            let f x = if hasExtension x then f $ takeDirectory x else x
            in f $ takeDirectory $ drop (length output + 1) x
    want $ concat
        [ [s </> "Main" <.> exe, s </> "config.txt"] | t <- tests, let s = output </> t]
Ben Gamari's avatar
Ben Gamari committed
214
    when cachegrind $ want [ "cachegrind" ]
Ben Gamari's avatar
Ben Gamari committed
215

Ben Gamari's avatar
Ben Gamari committed
216 217 218 219 220 221 222 223 224
    "//all-results" %> \out -> do
        let results = [ s </> "Main" <.> exe <.> "result"
                      | t <- tests
                      , let s = output </> t
                      ]
        need results
        xs <- mapM readFileLines results
        writeFileLines out (concat xs)

Ben Gamari's avatar
Ben Gamari committed
225 226 227 228 229 230 231 232 233
    "//cachegrind" %> \out -> do
        let results = [ s </> "Main" <.> "cachegrind" <.> "result"
                      | t <- tests
                      , let s = output </> t
                      ]
        need results
        xs <- mapM readFileLines results
        writeFileLines out (concat xs)

Ben Gamari's avatar
Ben Gamari committed
234 235 236
    "//config.txt" %> \out -> do
        let dir = unoutput out
        src <- readFileLines $ dir </> "Makefile"
Ben Gamari's avatar
SHake  
Ben Gamari committed
237
        let poss = ["Main.hs","Main.lhs","Era.hs","SumEuler.hs",takeFileName dir <.> "hs",takeFileName dir <.> "lhs"]
Ben Gamari's avatar
Ben Gamari committed
238 239 240 241 242 243
        bs <- filterM (doesFileExist . (dir </>)) poss
        let mainMod = case bs of
                [] -> error $ "Could not find Main file for " ++ dir
                x:_ -> "MAIN = " ++ x
        writeFileLines out $ mainMod : convertConfig src

Ben Gamari's avatar
Ben Gamari committed
244
    ["//Main" <.> exe, "//Main" <.> exe <.> "result", "//Main.results.json"] &%> \[out, result, resultsJson] -> do
Ben Gamari's avatar
Ben Gamari committed
245 246 247 248 249 250 251 252
        deps <- readFile' $ replaceExtension out "deps"
        let os = nub [ if isLower $ head $ takeFileName x then replaceExtension out "o" else output </> x
                     | x <- words deps, takeExtension x == ".o"]
        need os
        config <- readConfig' $ takeDirectory out </> "config.txt"
        let dir = unoutput out
            obj = takeDirectory out
            name = takeFileName dir
Ben Gamari's avatar
Ben Gamari committed
253 254 255
        resultHdl <- liftIO $ openFile result WriteMode

        -- Add results from object compilation to results output
Ben Gamari's avatar
Ben Gamari committed
256
        objectResults <- forM os $ \o -> do
Ben Gamari's avatar
Ben Gamari committed
257 258
            ls <- liftIO $ BS.readFile (o <.> "result")
            liftIO $ BS.hPutStr resultHdl ls
Ben Gamari's avatar
Ben Gamari committed
259 260
            Just ms <- liftIO $ MTree.readFile (o <.> "results.json")
            return ms
Ben Gamari's avatar
Ben Gamari committed
261 262 263 264 265 266 267 268 269 270

        -- Link executable
        liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ name ++ " : time to link " ++ name ++ " follows..."
        Stdouterr out_err <- withResource r 1 $
            cmd compiler $ ["-Rghc-timing","-rtsopts","-o", out] ++ os ++ way ++ words (config "SRC_HC_OPTS")
        liftIO $ BS.hPutStr resultHdl out_err
        liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ name ++ ": size of " ++ name ++ " follows..."

        -- Report executable size
        Stdout out_err <- cmd "size" [out]
Ben Gamari's avatar
Ben Gamari committed
271
        let execSize = ParseResults.parseCodeSize $ BS.unpack out_err
Ben Gamari's avatar
Ben Gamari committed
272 273 274
        liftIO $ BS.hPutStr resultHdl out_err
        liftIO $ hClose resultHdl

Ben Gamari's avatar
Ben Gamari committed
275 276 277
        liftIO $ MTree.writeFile resultsJson 
            $ fold objectResults
           <> MTree.singleton (ml "executable size") (realToFrac execSize)
Ben Gamari's avatar
Ben Gamari committed
278 279 280


    ["//*.o","//*.hi","//*.o.result","//*.o.results.json"] &%> \[o,hi,result,resultsJson] -> do
Ben Gamari's avatar
Ben Gamari committed
281 282 283 284 285 286 287 288 289 290
        let dir = unoutput o
            obj = output </> dir
        config <- readConfig' $ obj </> "config.txt"
        let mod = let x = dropExtension $ drop (length obj + 1) o
                  in if x == "Main" then dropExtension $ config "MAIN" else x
        src <- do b <- doesFileExist $ dir </> mod <.> "hs"
                  return $ dir </> mod <.> (if b then "hs" else "lhs")
        deps <- readFileLines $ obj </> "Main.deps"
        need [ if takeExtension r `elem` [".h",".hs",".lhs"] then r else output </> r
             | lhs:":":rhs <- map words $ deps, dir </> mod <.> "o" == lhs, r <- rhs]
Ben Gamari's avatar
Ben Gamari committed
291
        let test = takeFileName dir
Ben Gamari's avatar
Ben Gamari committed
292
        resultHdl <- liftIO $ openFile result WriteMode
Ben Gamari's avatar
Ben Gamari committed
293 294
        liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ test ++ " : time to compile " ++ mod ++ " follows..."
        let rts_args = [ "+RTS", "--machine-readable", "-t"++o++".stats" ]
Ben Gamari's avatar
Ben Gamari committed
295
        Stdouterr out_err <- cmd compiler $ ["-Rghc-timing","-c",src,"-w","-i"++obj,"-odir="++obj,"-hidir="++obj] ++
Ben Gamari's avatar
Ben Gamari committed
296
                           way ++ words (config "SRC_HC_OPTS") ++ [compiler_args] ++ rts_args
Ben Gamari's avatar
Ben Gamari committed
297
        liftIO $ BS.hPutStr resultHdl out_err
Ben Gamari's avatar
Ben Gamari committed
298 299

        liftIO $ hPutStrLn resultHdl $ "==nofib== " ++ test ++ ": size of " ++ takeFileName o ++ " follows..."
Ben Gamari's avatar
Ben Gamari committed
300 301
        Stdout out_err <- cmd "size" [o]
        liftIO $ BS.hPutStr resultHdl out_err
Ben Gamari's avatar
Ben Gamari committed
302

Ben Gamari's avatar
Ben Gamari committed
303 304 305 306 307
        rtsStats <- liftIO $ readRtsStats $ o++".stats"
        liftIO $ MTree.writeFile resultsJson
            $ MTree.prefix (MTree.mkLabel test <> ml "objects" <> MTree.mkLabel (takeFileName o))
            $ MTree.singleton (ml "size") (realToFrac $ ParseResults.parseCodeSize $ BS.unpack out_err)
           <> MTree.prefix (ml "rts stats") rtsStats
Ben Gamari's avatar
Ben Gamari committed
308

Ben Gamari's avatar
Ben Gamari committed
309
        liftIO $ hClose resultHdl
Ben Gamari's avatar
Ben Gamari committed
310 311 312 313

    "//Main.deps" %> \out -> do
        let dir = unoutput out
        config <- readConfig' $ takeDirectory out </> "config.txt"
Ben Gamari's avatar
SHake  
Ben Gamari committed
314
        cmd_ compiler $ ["-w","-M",dir </> config "MAIN","-i" ++ dir,"-dep-makefile=" ++ out, "-dep-suffix", ""] ++
Ben Gamari's avatar
Ben Gamari committed
315 316 317 318
                           words (config "SRC_HC_OPTS")
        src <- liftIO $ readFile out
        need [x | x <- words src, takeExtension x `elem` [".hs",".lhs",".h"]]

Ben Gamari's avatar
Ben Gamari committed
319
    ["//Main.cachegrind.result", "//Main.cachegrind.results.json"] &%> \[out, resultsJson] -> do
Ben Gamari's avatar
Ben Gamari committed
320 321
        need [takeDirectory out </> "config.txt"]
        need [replaceExtensions out exe]
Ben Gamari's avatar
Ben Gamari committed
322 323 324
        let test = unoutput out
        (stdin, args) <- liftIO $ getTestCmdline nofib test
        executable <- liftIO $ IO.canonicalizePath $ output </> test </> "Main" <.> exe
Ben Gamari's avatar
Ben Gamari committed
325
        let rtsStatsOut = executable <.> "stats"
Ben Gamari's avatar
Ben Gamari committed
326
        out' <- liftIO $ IO.canonicalizePath out
327
        cmd_ (Cwd test) (EchoStdout False) (StdinBS stdin)
328 329
            "valgrind" "--tool=cachegrind" cachegrind_args ("--cachegrind-out-file="++out') 
            executable args "+RTS" rts_args "--machine-readable" ("-t"++rtsStatsOut)
Ben Gamari's avatar
Ben Gamari committed
330
        stats <- liftIO $ CachegrindParse.parse out'
331
        rtsStats <- liftIO $ readRtsStats rtsStatsOut
Ben Gamari's avatar
Ben Gamari committed
332
        liftIO $ MTree.writeFile resultsJson 
Ben Gamari's avatar
Ben Gamari committed
333
            $ MTree.fromList
334
              [ (MTree.mkLabel test <> ml "run" <> ml "cachegrind" <> lbl, realToFrac v)
Ben Gamari's avatar
Ben Gamari committed
335 336 337
              | (eventName, v) <- M.toList stats
              , let lbl = MTree.mkLabel $ CachegrindParse.getEventName eventName
              ]
338
           <> MTree.prefix (MTree.mkLabel test <> ml "run" <> ml "rts stats") rtsStats
Ben Gamari's avatar
Ben Gamari committed
339 340 341 342 343 344 345

  where
    objectsForExecutable :: FilePath -> Action [FilePath]
    objectsForExecutable executable = do
        deps <- readFile' $ replaceExtension executable "deps"
        return $ nub [ if isLower $ head $ takeFileName x then replaceExtension executable "o" else output </> x
                     | x <- words deps, takeExtension x == ".o"]
Ben Gamari's avatar
Ben Gamari committed
346

Ben Gamari's avatar
Ben Gamari committed
347
getTestCmdline :: Nofib -> String -> IO (BSL.ByteString, [String])
Ben Gamari's avatar
Ben Gamari committed
348
getTestCmdline nofib@Build{..} test = do
Ben Gamari's avatar
Ben Gamari committed
349 350
    config <- readConfig $ output </> test </> "config.txt"
    let args = words (config "PROG_ARGS") ++ words (config $ map toUpper (show speed) ++ "_OPTS")
Ben Gamari's avatar
Ben Gamari committed
351
    stdin <- let s = config "STDIN_FILE" in if s == "" then grab "stdin" else BSL.readFile $ test </> s
Ben Gamari's avatar
Ben Gamari committed
352 353
    return (stdin, args)
  where
Ben Gamari's avatar
Ben Gamari committed
354
    grab :: String -> IO BSL.ByteString
Ben Gamari's avatar
Ben Gamari committed
355 356 357 358
    grab ext = do
        let s = [test </> takeFileName test <.> map toLower (show speed) ++ ext
                ,test </> takeFileName test <.> ext]
        ss <- filterM IO.doesFileExist s
Ben Gamari's avatar
Ben Gamari committed
359
        maybe (return BSL.empty) BSL.readFile $ listToMaybe ss
Ben Gamari's avatar
Ben Gamari committed
360

Ben Gamari's avatar
Ben Gamari committed
361 362 363 364 365
readRtsStats :: FilePath -> IO (Measurements Double)
readRtsStats fname = do
    rtsStats <- ParseResults.parseRtsStats <$> readFile fname
    return $ MTree.fromList $ map (first MTree.mkLabel) $ M.toList rtsStats

Ben Gamari's avatar
Ben Gamari committed
366 367 368
-- | Run a test, checking stdout/stderr are as expected, and reporting time.
--   Return True if the test passes.
runTest :: Nofib -> String -> IO Bool
Ben Gamari's avatar
Ben Gamari committed
369
runTest nofib@Build{..} test = do
Ben Gamari's avatar
Ben Gamari committed
370
    putStrLn $ "==nofib== " ++ takeDirectory1 test ++ ": time to run " ++ takeDirectory1 test ++ " follows..."
Ben Gamari's avatar
Ben Gamari committed
371
    (stdin, args) <- getTestCmdline nofib test
Ben Gamari's avatar
Ben Gamari committed
372
    stats <- IO.canonicalizePath $ output </> test </> "stat.txt"
Ben Gamari's avatar
Ben Gamari committed
373
    executable <- liftIO $ IO.canonicalizePath $ output </> test </> "Main" <.> exe
Ben Gamari's avatar
Ben Gamari committed
374 375 376 377

    fmap and $ replicateM times $ do
        start <- getCurrentTime
        (code,stdout,stderr) <- readProcessWithExitCodeAndWorkingDirectory
378
            test executable (args++"+RTS":rts_args++["--machine-readable", "-t"++stats]) stdin
Ben Gamari's avatar
Ben Gamari committed
379
        end <- getCurrentTime
Ben Gamari's avatar
Ben Gamari committed
380

Ben Gamari's avatar
Ben Gamari committed
381 382
        stdoutWant <- grab "stdout"
        stderrWant <- grab "stderr"
Ben Gamari's avatar
Ben Gamari committed
383 384
        BSL.writeFile (output </> test </> "stdout") stdout
        BSL.writeFile (output </> test </> "stderr") stderr
Ben Gamari's avatar
Ben Gamari committed
385

Ben Gamari's avatar
Ben Gamari committed
386 387
        putStrLn $ show (floor $ fromRational (toRational $ end `diffUTCTime` start) * 1000) ++ "ms"
        putStr =<< readFile stats
Ben Gamari's avatar
Ben Gamari committed
388

Ben Gamari's avatar
Ben Gamari committed
389
        rtsStats <- readRtsStats stats
Ben Gamari's avatar
Ben Gamari committed
390
        MTree.writeFile (output </> test </> "run.results.json") 
Ben Gamari's avatar
Ben Gamari committed
391
            $ MTree.prefix (MTree.mkLabel test <> ml "run" <> ml "rts stats") rtsStats
Ben Gamari's avatar
Ben Gamari committed
392

Ben Gamari's avatar
Ben Gamari committed
393 394 395 396 397 398 399
        err <- return $
            if not skip_check && stderr /= stderrWant then "FAILED STDERR\nWANTED: " ++ snip stderrWant ++ "\nGOT: " ++ snip stderr
            else if not skip_check && stdout /= stdoutWant then "FAILED STDOUT\nWANTED: " ++ snip stdoutWant ++ "\nGOT: " ++ snip stdout
            else if not skip_check && code /= ExitSuccess then "FAILED EXIT CODE " ++ show code
            else ""
        if null err then return True else putStrLn err >> return False
    where
Ben Gamari's avatar
Ben Gamari committed
400 401
        snip :: BSL.ByteString -> String
        snip x = if BSL.length x > 200 then BSL.unpack (BSL.take 200 x) ++ "..." else BSL.unpack x
Ben Gamari's avatar
Ben Gamari committed
402

Ben Gamari's avatar
Ben Gamari committed
403
        grab :: String -> IO BSL.ByteString
Ben Gamari's avatar
Ben Gamari committed
404 405 406 407
        grab ext = do
            let s = [test </> takeFileName test <.> map toLower (show speed) ++ ext
                    ,test </> takeFileName test <.> ext]
            ss <- filterM IO.doesFileExist s
Ben Gamari's avatar
Ben Gamari committed
408
            maybe (return BSL.empty) BSL.readFile $ listToMaybe ss
Ben Gamari's avatar
Ben Gamari committed
409 410 411 412 413 414 415 416


---------------------------------------------------------------------
-- CONFIGURATION UTILITIES
-- The Makefile's are slurped for configuration, to produce a cleaned-up config file

-- | Given the source of a Makefile, slurp out the configuration strings.
convertConfig :: [String] -> [String]
417 418 419 420
convertConfig xs = 
      [ k ++ " = " ++ v
      | (k, v) <- M.toList vars
      ]
Ben Gamari's avatar
Ben Gamari committed
421
    where
422 423 424 425 426 427
        vars = 
            M.fromListWith (\a b -> a ++ " " ++ b)
            [ (remap a, b)
            | x <- xs
            , let (a,b) = separate x, a `elem` keep
            ]
Ben Gamari's avatar
Ben Gamari committed
428
        keep = words "PROG_ARGS SRC_HC_OPTS SLOW_OPTS NORM_OPTS FAST_OPTS STDIN_FILE"
Ben Gamari's avatar
Ben Gamari committed
429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471
        remap x = x

        separate x = (name,rest)
            where (name,x2) = span (\x -> isAlpha x || x == '_') x
                  rest = dropWhile isSpace $ dropWhile (`elem` "+=") $ dropWhile isSpace x2


-- | Read a configuration file (new format) into a function supplying options.
readConfig :: FilePath -> IO (String -> String)
readConfig x = do
    src <- readFile x
    let res = [ (reverse $ dropWhile isSpace $ reverse a, dropWhile isSpace $ drop 1 b)
              | y <- lines src, let (a,b) = break (== '=') y]
    return $ \x -> fromMaybe "" $ lookup x res


-- | readConfig lifted into the Action monad.
readConfig' :: FilePath -> Action (String -> String)
readConfig' x = do
    need [x]
    liftIO $ readConfig x


---------------------------------------------------------------------
-- GENERAL UTILITIES

-- | The executable extension on this platform.
exe :: String
exe = if os == "mingw32" then "exe" else ""


-- | Like the standard removeDirectoryRecursive, but doesn't fail if the path is missing.
removeDirectoryRecursive :: FilePath -> IO ()
removeDirectoryRecursive x = do
    b <- IO.doesDirectoryExist x
    when b $ IO.removeDirectoryRecursive x


-- | Source for readProcessWithExitCode, plus addition of cwd
readProcessWithExitCodeAndWorkingDirectory
    :: FilePath                 -- ^ directory to use
    -> FilePath                 -- ^ command to run
    -> [String]                 -- ^ any arguments
Ben Gamari's avatar
Ben Gamari committed
472 473
    -> BSL.ByteString           -- ^ standard input
    -> IO (ExitCode, BSL.ByteString, BSL.ByteString) -- ^ exitcode, stdout, stderr
Ben Gamari's avatar
Ben Gamari committed
474 475 476 477 478 479 480
readProcessWithExitCodeAndWorkingDirectory cwd cmd args input = do
    (Just inh, Just outh, Just errh, pid) <-
        createProcess (proc cmd args){ cwd     = Just cwd,
                                       std_in  = CreatePipe,
                                       std_out = CreatePipe,
                                       std_err = CreatePipe }
    outMVar <- newEmptyMVar
Ben Gamari's avatar
Ben Gamari committed
481 482 483 484 485
    out  <- BSL.hGetContents outh
    _ <- forkIO $ evaluate (BSL.length out) >> putMVar outMVar ()
    err  <- BSL.hGetContents errh
    _ <- forkIO $ evaluate (BSL.length err) >> putMVar outMVar ()
    when (not (BSL.null input)) $ do BSL.hPutStr inh input; hFlush inh
Ben Gamari's avatar
Ben Gamari committed
486 487 488 489 490 491 492 493
    hClose inh
    takeMVar outMVar
    takeMVar outMVar
    hClose outh
    hClose errh
    ex <- waitForProcess pid

    return (ex, out, err)