Actions.hs 2.14 KB
Newer Older
Andrey Mokhov's avatar
Andrey Mokhov committed
1
module Rules.Actions (
2
    build, buildWhen, run, verboseRun
Andrey Mokhov's avatar
Andrey Mokhov committed
3 4 5 6 7
    ) where

import Util
import Builder
import Expression
8
import qualified Target
9
import Settings.Args
10
import Settings.Util
Andrey Mokhov's avatar
Andrey Mokhov committed
11
import Oracles.ArgsHash
12
import Development.Shake
Andrey Mokhov's avatar
Andrey Mokhov committed
13 14 15 16 17 18

-- Build a given target using an appropriate builder. Force a rebuilt if the
-- argument list has changed since the last built (that is, track changes in
-- the build system).
build :: FullTarget -> Action ()
build target = do
Andrey Mokhov's avatar
Andrey Mokhov committed
19
    need $ Target.dependencies target
Andrey Mokhov's avatar
Andrey Mokhov committed
20 21 22
    argList <- interpret target args
    -- The line below forces the rule to be rerun if the args hash has changed
    argsHash <- askArgsHash target
23
    run (Target.builder target) argList
Andrey Mokhov's avatar
Andrey Mokhov committed
24

25 26 27 28 29
buildWhen :: Predicate -> FullTarget -> Action ()
buildWhen predicate target = do
    bool <- interpretExpr target predicate
    when bool $ build target

Andrey Mokhov's avatar
Andrey Mokhov committed
30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50
-- Run the builder with a given collection of arguments
verboseRun :: Builder -> [String] -> Action ()
verboseRun builder args = do
    needBuilder builder
    path <- builderPath builder
    cmd [path] args

-- Run the builder with a given collection of arguments printing out a
-- terse commentary with only 'interesting' info for the builder.
run :: Builder -> [String] -> Action ()
run builder args = do
    putColoured White $ "/--------\n" ++
        "| Running " ++ show builder ++ " with arguments:"
    mapM_ (putColoured White . ("|   " ++)) $ interestingInfo builder args
    putColoured White $ "\\--------"
    quietly $ verboseRun builder args

interestingInfo :: Builder -> [String] -> [String]
interestingInfo builder ss = case builder of
    Ar       -> prefixAndSuffix 2 1 ss
    Ld       -> prefixAndSuffix 4 0 ss
51 52 53 54
    Gcc _    -> prefixAndSuffix 0 4 ss
    GccM _   -> prefixAndSuffix 0 1 ss
    Ghc _    -> prefixAndSuffix 0 4 ss
    GhcM _   -> prefixAndSuffix 1 1 ss
Andrey Mokhov's avatar
Andrey Mokhov committed
55 56 57 58 59 60 61 62 63 64 65 66
    GhcPkg _ -> prefixAndSuffix 3 0 ss
    GhcCabal -> prefixAndSuffix 3 0 ss
    _        -> ss
  where
    prefixAndSuffix n m ss =
        if length ss <= n + m + 1
        then ss
        else take n ss
             ++ ["... skipping "
             ++ show (length ss - n - m)
             ++ " arguments ..."]
             ++ drop (length ss - m) ss