Actions.hs 11.3 KB
Newer Older
1
module Rules.Actions (
Andrey Mokhov's avatar
Andrey Mokhov committed
2
    build, buildWithCmdOptions, buildWithResources, copyFile, fixFile, moveFile,
3
4
    removeFile, copyDirectory, copyDirectoryContent, createDirectory,
    moveDirectory, removeDirectory, applyPatch, runBuilder, runBuilderWith,
5
    makeExecutable, renderProgram, renderLibrary, Match(..)
6
7
    ) where

8
import qualified System.Directory.Extra as IO
Andrey Mokhov's avatar
Andrey Mokhov committed
9
10
import qualified System.IO              as IO
import qualified Control.Exception.Base as IO
Andrey Mokhov's avatar
Andrey Mokhov committed
11

Ben Gamari's avatar
Ben Gamari committed
12
import Base
Andrey Mokhov's avatar
Andrey Mokhov committed
13
import CmdLineFlag
14
import Context
Andrey Mokhov's avatar
Andrey Mokhov committed
15
import Expression
16
import Oracles.ArgsHash
kaiha's avatar
kaiha committed
17
import Oracles.DirectoryContent
Andrey Mokhov's avatar
Andrey Mokhov committed
18
import Oracles.WindowsPath
19
import Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
20
import Settings.Builders.Ar
21
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
22
import UserSettings
Andrey Mokhov's avatar
Andrey Mokhov committed
23

Andrey Mokhov's avatar
Andrey Mokhov committed
24
25
26
27
28
29
30
31
-- | Build a 'Target' with the right 'Builder' and command line arguments.
-- Force a rebuild if the argument list has changed since the last build.
build :: Target -> Action ()
build = customBuild [] []

-- | Build a 'Target' with the right 'Builder' and command line arguments,
-- acquiring necessary resources. Force a rebuild if the argument list has
-- changed since the last build.
32
buildWithResources :: [(Resource, Int)] -> Target -> Action ()
Andrey Mokhov's avatar
Andrey Mokhov committed
33
34
35
36
37
38
39
40
41
42
buildWithResources rs = customBuild rs []

-- | Build a 'Target' with the right 'Builder' and command line arguments,
-- using given options when executing the build command. Force a rebuild if
-- the argument list has changed since the last build.
buildWithCmdOptions :: [CmdOption] -> Target -> Action ()
buildWithCmdOptions = customBuild []

customBuild :: [(Resource, Int)] -> [CmdOption] -> Target -> Action ()
customBuild rs opts target@Target {..} = do
43
    needBuilder builder
44
    path    <- builderPath builder
45
    argList <- interpret target getArgs
46
    verbose <- interpret target verboseCommands
Ben Gamari's avatar
Ben Gamari committed
47
    let quietlyUnlessVerbose = if verbose then withVerbosity Loud else quietly
Andrey Mokhov's avatar
Andrey Mokhov committed
48
    -- The line below forces the rule to be rerun if the args hash has changed.
49
    checkArgsHash target
50
    withResources rs $ do
51
        putInfo target
Ben Gamari's avatar
Ben Gamari committed
52
        quietlyUnlessVerbose $ case builder of
53
54
55
56
57
58
            Ar -> do
                output <- interpret target getOutput
                if "//*.a" ?== output
                then arCmd path argList
                else do
                    input <- interpret target getInput
59
                    top   <- topDirectory
Andrey Mokhov's avatar
Andrey Mokhov committed
60
61
62
63
                    cmd [Cwd output] [path] "x" (top -/- input)

            Configure dir -> do
                need [dir -/- "configure"]
64
                -- Inject /bin/bash into `libtool`, instead of /bin/sh
Andrey Mokhov's avatar
Andrey Mokhov committed
65
                let env = AddEnv "CONFIG_SHELL" "/bin/bash"
66
                cmd Shell cmdEcho env [Cwd dir] [path] opts argList
Andrey Mokhov's avatar
Andrey Mokhov committed
67

Andrey Mokhov's avatar
Andrey Mokhov committed
68
69
            HsCpp    -> captureStdout target path argList
            GenApply -> captureStdout target path argList
Andrey Mokhov's avatar
Andrey Mokhov committed
70

71
            GenPrimopCode -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
72
73
                src  <- interpret target getInput
                file <- interpret target getOutput
74
75
76
77
                input <- readFile' src
                Stdout output <- cmd (Stdin input) [path] argList
                writeFileChanged file output

Andrey Mokhov's avatar
Andrey Mokhov committed
78
79
80
81
            Make dir -> do
                need [dir -/- "Makefile"]
                cmd Shell cmdEcho path ["-C", dir] argList

82
83
            _  -> cmd [path] argList

84
85
86
cmdEcho :: CmdOption
cmdEcho = EchoStdout $ cmdProgressInfo `elem` [Normal, Unicorn]

Andrey Mokhov's avatar
Andrey Mokhov committed
87
-- | Run a builder, capture the standard output, and write it to a given file.
Andrey Mokhov's avatar
Andrey Mokhov committed
88
89
90
91
92
93
captureStdout :: Target -> FilePath -> [String] -> Action ()
captureStdout target path argList = do
    file <- interpret target getOutput
    Stdout output <- cmd [path] argList
    writeFileChanged file output

Andrey Mokhov's avatar
Andrey Mokhov committed
94
-- | Copy a file tracking the source.
95
96
copyFile :: FilePath -> FilePath -> Action ()
copyFile source target = do
97
    need [source] -- Guarantee source is built before printing progress info.
98
    putProgressInfo $ renderAction "Copy file" source target
99
    copyFileChanged source target
100

Andrey Mokhov's avatar
Andrey Mokhov committed
101
-- | Move a file; we cannot track the source, because it is moved.
102
103
104
105
moveFile :: FilePath -> FilePath -> Action ()
moveFile source target = do
    putProgressInfo $ renderAction "Move file" source target
    liftIO $ IO.renameFile source target
106

107
108
109
110
111
112
-- | Remove a file that doesn't necessarily exist.
removeFile :: FilePath -> Action ()
removeFile file = do
    putBuild $ "| Remove file " ++ file
    liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file

Andrey Mokhov's avatar
Andrey Mokhov committed
113
-- | Create a directory if it does not already exist.
114
115
createDirectory :: FilePath -> Action ()
createDirectory dir = do
116
    putBuild $ "| Create directory " ++ dir
117
118
    liftIO $ IO.createDirectoryIfMissing True dir

Andrey Mokhov's avatar
Andrey Mokhov committed
119
-- | Remove a directory that doesn't necessarily exist.
120
121
122
removeDirectory :: FilePath -> Action ()
removeDirectory dir = do
    putBuild $ "| Remove directory " ++ dir
Andrey Mokhov's avatar
Andrey Mokhov committed
123
    liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir
124

Andrey Mokhov's avatar
Andrey Mokhov committed
125
-- | Copy a directory. The contents of the source directory is untracked.
126
127
128
copyDirectory :: FilePath -> FilePath -> Action ()
copyDirectory source target = do
    putProgressInfo $ renderAction "Copy directory" source target
129
    quietly $ cmd cmdEcho ["cp", "-r", source, target]
130

kaiha's avatar
kaiha committed
131
132
-- | Copy the content of the source directory into the target directory.
-- The copied content is tracked.
133
134
copyDirectoryContent :: Match -> FilePath -> FilePath -> Action ()
copyDirectoryContent expr source target = do
kaiha's avatar
kaiha committed
135
    putProgressInfo $ renderAction "Copy directory content" source target
136
    getDirectoryContent expr source >>= mapM_ cp
137
  where
kaiha's avatar
kaiha committed
138
139
140
    cp a = do
        createDirectory $ dropFileName $ target' a
        copyFile a $ target' a
141
142
    target' a = target -/- fromJust (stripPrefix source a)

Andrey Mokhov's avatar
Andrey Mokhov committed
143
-- | Move a directory. The contents of the source directory is untracked.
144
145
moveDirectory :: FilePath -> FilePath -> Action ()
moveDirectory source target = do
146
    putProgressInfo $ renderAction "Move directory" source target
147
    quietly $ cmd cmdEcho ["mv", source, target]
148

Andrey Mokhov's avatar
Andrey Mokhov committed
149
-- | Transform a given file by applying a function to its contents.
150
151
fixFile :: FilePath -> (String -> String) -> Action ()
fixFile file f = do
152
    putBuild $ "| Fix " ++ file
Andrey Mokhov's avatar
Andrey Mokhov committed
153
154
155
156
157
158
    contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do
        old <- IO.hGetContents h
        let new = f old
        IO.evaluate $ rnf new
        return new
    liftIO $ writeFile file contents
159

160
161
162
applyPatch :: FilePath -> FilePath -> Action ()
applyPatch dir patch = do
    let file = dir -/- patch
163
    needBuilder Patch
164
165
    path <- builderPath Patch
    putBuild $ "| Apply patch " ++ file
166
    quietly $ cmd Shell cmdEcho [Cwd dir] [path, "-p0 <", patch]
167

168
runBuilder :: Builder -> [String] -> Action ()
kaiha's avatar
kaiha committed
169
runBuilder = runBuilderWith []
170
171
172

runBuilderWith :: [CmdOption] -> Builder -> [String] -> Action ()
runBuilderWith options builder args = do
173
    needBuilder builder
174
    path <- builderPath builder
175
    let note = if null args then "" else " (" ++ intercalate ", " args ++ ")"
176
    putBuild $ "| Run " ++ show builder ++ note
177
    quietly $ cmd options [path] args
178

179
180
makeExecutable :: FilePath -> Action ()
makeExecutable file = do
Andrey Mokhov's avatar
Andrey Mokhov committed
181
    putBuild $ "| Make " ++ quote file ++ " executable."
182
183
    quietly $ cmd "chmod +x " [file]

Andrey Mokhov's avatar
Andrey Mokhov committed
184
-- | Print out information about the command being executed.
185
186
187
putInfo :: Target -> Action ()
putInfo Target {..} = putProgressInfo $ renderAction
    ("Run " ++ show builder ++ contextInfo) (digest inputs) (digest outputs)
Andrey Mokhov's avatar
Andrey Mokhov committed
188
  where
189
190
191
192
193
    contextInfo = concat $ [ " (" ]
        ++ [ "stage = "     ++ show (stage context) ]
        ++ [ ", package = " ++ pkgNameString (package context) ]
        ++ [ ", way = "     ++ show (way context) | way context /= vanilla ]
        ++ [ ")" ]
194
195
196
    digest [] = "none"
    digest [x] = x
    digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
Moritz Angermann's avatar
Moritz Angermann committed
197

198
-- | Version of @putBuild@ controlled by @progressInfo@ command line flag.
Moritz Angermann's avatar
Moritz Angermann committed
199
putProgressInfo :: String -> Action ()
200
putProgressInfo msg = when (cmdProgressInfo /= None) $ putBuild msg
Moritz Angermann's avatar
Moritz Angermann committed
201
202

-- | Render an action.
203
renderAction :: String -> FilePath -> FilePath -> String
204
renderAction what input output = case cmdProgressInfo of
205
206
207
    Normal  -> renderBox [ what, "     input: " ++ i, " => output: " ++ o ]
    Brief   -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
    Unicorn -> renderUnicorn [ what, "     input: " ++ i, " => output: " ++ o ]
208
    None    -> ""
209
210
211
  where
    i = unifyPath input
    o = unifyPath output
Moritz Angermann's avatar
Moritz Angermann committed
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261

-- | Render the successful build of a program
renderProgram :: String -> String -> String -> String
renderProgram name bin synopsis = renderBox [ "Successfully built program " ++ name
                                            , "Executable: " ++ bin
                                            , "Program synopsis: " ++ synopsis ++ "."]

-- | Render the successful built of a library
renderLibrary :: String -> String -> String -> String
renderLibrary name lib synopsis = renderBox [ "Successfully built library " ++ name
                                            , "Library: " ++ lib
                                            , "Library synopsis: " ++ synopsis ++ "."]

-- | Render the given set of lines next to our favorit unicorn Robert.
renderUnicorn :: [String] -> String
renderUnicorn ls =
    unlines $ take (max (length ponyLines) (length boxLines)) $
        zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
  where
    ponyLines :: [String]
    ponyLines = [ "                   ,;,,;'"
                , "                  ,;;'(    Robert the spitting unicorn"
                , "       __       ,;;' ' \\   wants you to know"
                , "     /'  '\\'~~'~' \\ /'\\.)  that a task      "
                , "  ,;(      )    /  |.  /   just finished!   "
                , " ,;' \\    /-.,,(   ) \\                      "
                , " ^    ) /       ) / )|     Almost there!    "
                , "      ||        ||  \\)                      "
                , "      (_\\       (_\\                         " ]
    ponyPadding :: String
    ponyPadding = "                                            "
    boxLines :: [String]
    boxLines = ["", "", ""] ++ (lines . renderBox $ ls)

-- | Render the given set of lines in a nice box of ASCII.
--
-- The minimum width and whether to use Unicode symbols are hardcoded in the
-- function's body.
--
-- >>> renderBox (words "lorem ipsum")
-- /----------\
-- | lorem    |
-- | ipsum    |
-- \----------/
renderBox :: [String] -> String
renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
  where
    -- Minimum total width of the box in characters
    minimumBoxWidth = 32

262
263
    -- TODO: Make this setting configurable? Setting to True by default seems
    -- to work poorly with many fonts.
Moritz Angermann's avatar
Moritz Angermann committed
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
    useUnicode = False

    -- Characters to draw the box
    (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
        | useUnicode = ('─', '│', '╭',  '╮', '╰', '╯', ' ')
        | otherwise  = ('-', '|', '/', '\\', '\\', '/', ' ')

    -- Box width, taking minimum desired length and content into account.
    -- The -4 is for the beginning and end pipe/padding symbols, as
    -- in "| xxx |".
    boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
      where
        maxContentLength = maximum (map length ls)

    renderLine l = concat
        [ [pipe, padding]
        , padToLengthWith boxContentWidth padding l
        , [padding, pipe] ]
      where
        padToLengthWith n filler x = x ++ replicate (n - length x) filler

    (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
                       , botLeft : dashes ++ [botRight] )
      where
        -- +1 for each non-dash (= corner) char
        dashes = replicate (boxContentWidth + 2) dash