Actions.hs 4.75 KB
Newer Older
1
{-# LANGUAGE RecordWildCards #-}
2
3
4
5
6
7
module Rules.Actions (
    build, buildWithResources, copyFile, createDirectory, moveDirectory,
    fixFile, runConfigure, runMake, runBuilder
    ) where

import qualified System.Directory as IO
Andrey Mokhov's avatar
Andrey Mokhov committed
8

Ben Gamari's avatar
Ben Gamari committed
9
import Base
Andrey Mokhov's avatar
Andrey Mokhov committed
10
import Expression
11
import Oracles
12
import Oracles.ArgsHash
13
import Settings
14
import Settings.Args
Andrey Mokhov's avatar
Andrey Mokhov committed
15
import Settings.Builders.Ar
16
import qualified Target
Andrey Mokhov's avatar
Andrey Mokhov committed
17

18
19
20
-- Build a given target using an appropriate builder and acquiring necessary
-- resources. Force a rebuilt if the argument list has changed since the last
-- built (that is, track changes in the build system).
21
buildWithResources :: [(Resource, Int)] -> Target -> Action ()
22
buildWithResources rs target = do
23
    let builder = Target.builder target
Andrey Mokhov's avatar
Andrey Mokhov committed
24
    needBuilder laxDependencies builder
25
    path    <- builderPath builder
26
    argList <- interpret target getArgs
27
    verbose <- interpret target verboseCommands
Ben Gamari's avatar
Ben Gamari committed
28
    let quietlyUnlessVerbose = if verbose then withVerbosity Loud else quietly
Andrey Mokhov's avatar
Andrey Mokhov committed
29
    -- The line below forces the rule to be rerun if the args hash has changed
30
    checkArgsHash target
31
    withResources rs $ do
32
        unless verbose $ putInfo target
Ben Gamari's avatar
Ben Gamari committed
33
        quietlyUnlessVerbose $ case builder of
34
35
36
37
38
39
            Ar -> do
                output <- interpret target getOutput
                if "//*.a" ?== output
                then arCmd path argList
                else do
                    input <- interpret target getInput
40
                    top   <- topDirectory
41
                    cmd [path] [Cwd output] "x" (top -/- input)
Andrey Mokhov's avatar
Andrey Mokhov committed
42

Andrey Mokhov's avatar
Andrey Mokhov committed
43
44
            HsCpp    -> captureStdout target path argList
            GenApply -> captureStdout target path argList
Andrey Mokhov's avatar
Andrey Mokhov committed
45

46
            GenPrimopCode -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
47
48
                src  <- interpret target getInput
                file <- interpret target getOutput
49
50
51
52
53
54
                input <- readFile' src
                Stdout output <- cmd (Stdin input) [path] argList
                writeFileChanged file output

            _  -> cmd [path] argList

55
-- Most targets are built without explicitly acquiring resources
56
build :: Target -> Action ()
57
build = buildWithResources []
58

Andrey Mokhov's avatar
Andrey Mokhov committed
59
60
61
62
63
64
captureStdout :: Target -> FilePath -> [String] -> Action ()
captureStdout target path argList = do
    file <- interpret target getOutput
    Stdout output <- cmd [path] argList
    writeFileChanged file output

65
66
67
68
69
70
71
72
73
copyFile :: FilePath -> FilePath -> Action ()
copyFile source target = do
    putBuild $ renderBox [ "Copy file"
                         , "    input: " ++ source
                         , "=> output: " ++ target ]
    copyFileChanged source target

createDirectory :: FilePath -> Action ()
createDirectory dir = do
74
    putBuild $ "| Create directory " ++ dir
75
76
77
78
79
80
81
82
83
84
85
86
87
    liftIO $ IO.createDirectoryIfMissing True dir

-- Note, the source directory is untracked
moveDirectory :: FilePath -> FilePath -> Action ()
moveDirectory source target = do
    putBuild $ renderBox [ "Move directory"
                         , "    input: " ++ source
                         , "=> output: " ++ target ]
    liftIO $ IO.renameDirectory source target

-- Transform a given file by applying a function to its contents
fixFile :: FilePath -> (String -> String) -> Action ()
fixFile file f = do
88
    putBuild $ "| Fix " ++ file
89
90
91
92
93
94
95
    old <- liftIO $ readFile file
    let new = f old
    length new `seq` liftIO $ writeFile file new

runConfigure :: FilePath -> [CmdOption] -> [String] -> Action ()
runConfigure dir opts args = do
    need [dir -/- "configure"]
96
    putBuild $ "| Run configure in " ++ dir ++ "..."
97
98
99
100
101
102
    quietly $ cmd Shell (EchoStdout False) [Cwd dir] "bash configure" opts args

runMake :: FilePath -> [String] -> Action ()
runMake dir args = do
    need [dir -/- "Makefile"]
    let note = if null args then "" else " (" ++ intercalate "," args ++ ")"
103
    putBuild $ "| Run make" ++ note ++ " in " ++ dir ++ "..."
104
105
106
107
108
109
110
    quietly $ cmd Shell (EchoStdout False) "make" ["-C", dir, "MAKEFLAGS="] args

runBuilder :: Builder -> [String] -> Action ()
runBuilder builder args = do
    needBuilder laxDependencies builder
    path <- builderPath builder
    let note = if null args then "" else " (" ++ intercalate "," args ++ ")"
111
    putBuild $ "| Run " ++ show builder ++ note
112
113
    quietly $ cmd [path] args

114
115
-- Print out key information about the command being executed
putInfo :: Target.Target -> Action ()
116
117
putInfo (Target.Target {..}) = putBuild $ renderBox
    [ "Run " ++ show builder
118
119
      ++ " (" ++ stageInfo
      ++ "package = " ++ pkgNameString package
120
      ++ wayInfo ++ ")"
121
122
    , "    input: " ++ digest inputs
    , "=> output: " ++ digest outputs ]
Andrey Mokhov's avatar
Andrey Mokhov committed
123
  where
124
125
126
127
128
129
    stageInfo = if isStaged builder then "" else "stage = " ++ show stage ++ ", "
    wayInfo   = if way == vanilla   then "" else ", way = " ++ show way
    digest list = case list of
        []  -> "none"
        [x] -> x
        xs  -> head xs ++ " (and " ++ show (length xs - 1) ++ " more)"