Util.hs 14.5 KB
Newer Older
1
module Util (
Andrey Mokhov's avatar
Andrey Mokhov committed
2
    build, buildWithCmdOptions, buildWithResources, copyFile, fixFile, moveFile,
Andrey Mokhov's avatar
Andrey Mokhov committed
3
    removeFile, copyDirectory, copyDirectoryContents, createDirectory,
4
    moveDirectory, removeDirectory, applyPatch, runBuilder, runBuilderWith,
Andrey Mokhov's avatar
Andrey Mokhov committed
5
    makeExecutable, renderProgram, renderLibrary, builderEnvironment,
6
    needBuilder, copyFileUntracked, installDirectory, installData, installScript,
7
    installProgram, linkSymbolic
8
9
    ) where

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

14
15
import Hadrian.Oracles.ArgsHash

Ben Gamari's avatar
Ben Gamari committed
16
import Base
Andrey Mokhov's avatar
Andrey Mokhov committed
17
import CmdLineFlag
18
import Context
Andrey Mokhov's avatar
Andrey Mokhov committed
19
import Expression
20
import GHC
Andrey Mokhov's avatar
Andrey Mokhov committed
21
import Oracles.DirectoryContents
22
import Oracles.Path
23
import Oracles.Config.Setting
24
import Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
25
import Settings.Builders.Ar
26
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
27
import UserSettings
Andrey Mokhov's avatar
Andrey Mokhov committed
28

Andrey Mokhov's avatar
Andrey Mokhov committed
29
30
31
32
33
34
35
36
-- | 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.
37
buildWithResources :: [(Resource, Int)] -> Target -> Action ()
Andrey Mokhov's avatar
Andrey Mokhov committed
38
39
40
41
42
43
44
45
46
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 ()
47
48
49
50
customBuild rs opts target = do
    let targetBuilder = builder target
    needBuilder targetBuilder
    path    <- builderPath targetBuilder
51
    argList <- interpret target getArgs
52
    verbose <- interpret target verboseCommands
Ben Gamari's avatar
Ben Gamari committed
53
    let quietlyUnlessVerbose = if verbose then withVerbosity Loud else quietly
Andrey Mokhov's avatar
Andrey Mokhov committed
54
    checkArgsHash target -- Rerun the rule if the hash of argList has changed.
55
    withResources rs $ do
56
        putInfo target
57
        quietlyUnlessVerbose $ case targetBuilder of
58
            Ar _ -> do
59
60
61
62
63
                output <- interpret target getOutput
                if "//*.a" ?== output
                then arCmd path argList
                else do
                    input <- interpret target getInput
64
                    top   <- topDirectory
65
                    cmd cmdEcho [Cwd output] [path] "x" (top -/- input)
Andrey Mokhov's avatar
Andrey Mokhov committed
66
67

            Configure dir -> do
Ben Gamari's avatar
Ben Gamari committed
68
69
70
71
                -- Inject /bin/bash into `libtool`, instead of /bin/sh, otherwise Windows breaks.
                -- TODO: Figure out why.
                bash <- bashPath
                let env = AddEnv "CONFIG_SHELL" bash
72
                cmd Shell cmdEcho env [Cwd dir] [path] opts argList
Andrey Mokhov's avatar
Andrey Mokhov committed
73

Andrey Mokhov's avatar
Andrey Mokhov committed
74
75
            HsCpp    -> captureStdout target path argList
            GenApply -> captureStdout target path argList
Andrey Mokhov's avatar
Andrey Mokhov committed
76

77
            GenPrimopCode -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
78
79
                src  <- interpret target getInput
                file <- interpret target getOutput
80
                input <- readFile' src
Andrey Mokhov's avatar
Andrey Mokhov committed
81
                Stdout output <- cmd (Stdin input) [path] argList
82
83
                writeFileChanged file output

84
            Make dir -> cmd Shell cmdEcho path ["-C", dir] argList
Andrey Mokhov's avatar
Andrey Mokhov committed
85

86
            _  -> cmd cmdEcho [path] argList
87

88
-- | Suppress build output depending on the @--progress-info@ flag.
89
90
91
cmdEcho :: CmdOption
cmdEcho = EchoStdout $ cmdProgressInfo `elem` [Normal, Unicorn]

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

99
-- | Copy a file tracking the source, create the target directory if missing.
100
101
copyFile :: FilePath -> FilePath -> Action ()
copyFile source target = do
102
    need [source] -- Guarantee source is built before printing progress info.
Andrey Mokhov's avatar
Andrey Mokhov committed
103
    let dir = takeDirectory target
Zhen Zhang's avatar
Zhen Zhang committed
104
    liftIO $ IO.createDirectoryIfMissing True dir
105
    putProgressInfo $ renderAction "Copy file" source target
106
    copyFileChanged source target
107

108
-- | Copy a file without tracking the source, create the target directory if missing.
Zhen Zhang's avatar
Zhen Zhang committed
109
110
111
112
113
114
115
copyFileUntracked :: FilePath -> FilePath -> Action ()
copyFileUntracked source target = do
    let dir = takeDirectory target
    liftIO $ IO.createDirectoryIfMissing True dir
    putProgressInfo $ renderAction "Copy file (Untracked)" source target
    liftIO $ IO.copyFile source target

Andrey Mokhov's avatar
Andrey Mokhov committed
116
-- | Move a file; we cannot track the source, because it is moved.
117
118
119
moveFile :: FilePath -> FilePath -> Action ()
moveFile source target = do
    putProgressInfo $ renderAction "Move file" source target
Andrey Mokhov's avatar
Andrey Mokhov committed
120
    quietly $ cmd ["mv", source, target]
121

122
123
124
125
126
127
-- | 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
128
-- | Create a directory if it does not already exist.
129
130
createDirectory :: FilePath -> Action ()
createDirectory dir = do
131
    putBuild $ "| Create directory " ++ dir
132
133
    liftIO $ IO.createDirectoryIfMissing True dir

Andrey Mokhov's avatar
Andrey Mokhov committed
134
-- | Remove a directory that doesn't necessarily exist.
135
136
137
removeDirectory :: FilePath -> Action ()
removeDirectory dir = do
    putBuild $ "| Remove directory " ++ dir
Andrey Mokhov's avatar
Andrey Mokhov committed
138
    liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir
139

Andrey Mokhov's avatar
Andrey Mokhov committed
140
-- | Copy a directory. The contents of the source directory is untracked.
141
142
143
copyDirectory :: FilePath -> FilePath -> Action ()
copyDirectory source target = do
    putProgressInfo $ renderAction "Copy directory" source target
144
    quietly $ cmd ["cp", "-r", source, target]
145

Andrey Mokhov's avatar
Andrey Mokhov committed
146
147
148
149
150
151
152
-- | Copy the contents of the source directory that matches a given 'Match'
-- expression into the target directory. The copied contents is tracked.
copyDirectoryContents :: Match -> FilePath -> FilePath -> Action ()
copyDirectoryContents expr source target = do
    putProgressInfo $ renderAction "Copy directory contents" source target
    let cp file = copyFile file $ target -/- makeRelative source file
    mapM_ cp =<< directoryContents expr source
153

Andrey Mokhov's avatar
Andrey Mokhov committed
154
-- | Move a directory. The contents of the source directory is untracked.
155
156
moveDirectory :: FilePath -> FilePath -> Action ()
moveDirectory source target = do
157
    putProgressInfo $ renderAction "Move directory" source target
158
    quietly $ cmd ["mv", source, target]
159

Andrey Mokhov's avatar
Andrey Mokhov committed
160
-- | Transform a given file by applying a function to its contents.
161
162
fixFile :: FilePath -> (String -> String) -> Action ()
fixFile file f = do
163
    putBuild $ "| Fix " ++ file
Andrey Mokhov's avatar
Andrey Mokhov committed
164
165
166
167
168
169
    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
170

171
-- | Apply a patch by executing the 'Patch' builder in a given directory.
172
173
174
applyPatch :: FilePath -> FilePath -> Action ()
applyPatch dir patch = do
    let file = dir -/- patch
175
    needBuilder Patch
176
177
    path <- builderPath Patch
    putBuild $ "| Apply patch " ++ file
178
    quietly $ cmd Shell [Cwd dir] [path, "-p0 <", patch]
179

180
181
182
183
184
185
-- | Install a directory.
installDirectory :: FilePath -> Action ()
installDirectory dir = do
    path <- fixAbsolutePathOnWindows =<< setting InstallDir
    putBuild $ "| Install directory " ++ dir
    quietly $ cmd path dir
186

187
-- | Install data files to a directory and track them.
188
189
installData :: [FilePath] -> FilePath -> Action ()
installData fs dir = do
190
    path <- fixAbsolutePathOnWindows =<< setting InstallData
191
    need fs
192
193
    forM_ fs $ \f -> putBuild $ "| Install data " ++ f ++ " to " ++ dir
    quietly $ cmd path fs dir
194

195
-- | Install an executable file to a directory and track it.
196
197
installProgram :: FilePath -> FilePath -> Action ()
installProgram f dir = do
198
    path <- fixAbsolutePathOnWindows =<< setting InstallProgram
199
    need [f]
200
    putBuild $ "| Install program " ++ f ++ " to " ++ dir
201
    quietly $ cmd path f dir
202

203
-- | Install an executable script to a directory and track it.
204
205
installScript :: FilePath -> FilePath -> Action ()
installScript f dir = do
206
    path <- fixAbsolutePathOnWindows =<< setting InstallScript
207
    need [f]
208
    putBuild $ "| Install script " ++ f ++ " to " ++ dir
209
    quietly $ cmd path f dir
210

211
212
-- | Create a symbolic link from source file to target file (when symbolic links
-- are supported) and track the source file.
213
214
215
linkSymbolic :: FilePath -> FilePath -> Action ()
linkSymbolic source target = do
    lns <- setting LnS
216
    unless (null lns) $ do
217
218
219
220
221
222
        need [source] -- Guarantee source is built before printing progress info.
        let dir = takeDirectory target
        liftIO $ IO.createDirectoryIfMissing True dir
        putProgressInfo $ renderAction "Create symbolic link" source target
        quietly $ cmd lns source target

223
224
225
226
227
228
isInternal :: Builder -> Bool
isInternal = isJust . builderProvenance

-- | Make sure a 'Builder' exists and rebuild it if out of date.
needBuilder :: Builder -> Action ()
needBuilder (Configure dir) = need [dir -/- "configure"]
229
needBuilder (Make      dir) = need [dir -/- "Makefile"]
230
231
232
233
234
235
236
237
238
239
240
needBuilder builder         = when (isInternal builder) $ do
    path <- builderPath builder
    need [path]

-- | Write a Builder's path into a given environment variable.
builderEnvironment :: String -> Builder -> Action CmdOption
builderEnvironment variable builder = do
    needBuilder builder
    path <- builderPath builder
    return $ AddEnv variable path

241
runBuilder :: Builder -> [String] -> Action ()
kaiha's avatar
kaiha committed
242
runBuilder = runBuilderWith []
243

244
-- | Run a builder with given list of arguments using custom 'cmd' options.
245
246
runBuilderWith :: [CmdOption] -> Builder -> [String] -> Action ()
runBuilderWith options builder args = do
247
    needBuilder builder
248
    path <- builderPath builder
249
    let note = if null args then "" else " (" ++ intercalate ", " args ++ ")"
250
    putBuild $ "| Run " ++ show builder ++ note
251
    quietly $ cmd options [path] args
252

253
-- | Make a given file executable by running the @chmod@ command.
254
255
makeExecutable :: FilePath -> Action ()
makeExecutable file = do
Andrey Mokhov's avatar
Andrey Mokhov committed
256
    putBuild $ "| Make " ++ quote file ++ " executable."
257
258
    quietly $ cmd "chmod +x " [file]

Andrey Mokhov's avatar
Andrey Mokhov committed
259
-- | Print out information about the command being executed.
260
putInfo :: Target -> Action ()
261
262
263
264
putInfo t = putProgressInfo $ renderAction
    ("Run " ++ show (builder t) ++ contextInfo)
    (digest $ inputs  t)
    (digest $ outputs t)
Andrey Mokhov's avatar
Andrey Mokhov committed
265
  where
266
    contextInfo = concat $ [ " (" ]
267
268
269
        ++ [ "stage = "     ++ show (stage $ context t) ]
        ++ [ ", package = " ++ pkgNameString (package $ context t) ]
        ++ [ ", way = "     ++ show (way $ context t) | (way $ context t) /= vanilla ]
270
        ++ [ ")" ]
271
272
273
    digest [] = "none"
    digest [x] = x
    digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
Moritz Angermann's avatar
Moritz Angermann committed
274

275
-- | Version of @putBuild@ controlled by @progressInfo@ command line flag.
Moritz Angermann's avatar
Moritz Angermann committed
276
putProgressInfo :: String -> Action ()
277
putProgressInfo msg = when (cmdProgressInfo /= None) $ putBuild msg
Moritz Angermann's avatar
Moritz Angermann committed
278
279

-- | Render an action.
280
renderAction :: String -> FilePath -> FilePath -> String
281
renderAction what input output = case cmdProgressInfo of
282
283
284
    Normal  -> renderBox [ what, "     input: " ++ i, " => output: " ++ o ]
    Brief   -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
    Unicorn -> renderUnicorn [ what, "     input: " ++ i, " => output: " ++ o ]
285
    None    -> ""
286
287
288
  where
    i = unifyPath input
    o = unifyPath output
Moritz Angermann's avatar
Moritz Angermann committed
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338

-- | 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

339
340
    -- TODO: Make this setting configurable? Setting to True by default seems
    -- to work poorly with many fonts.
Moritz Angermann's avatar
Moritz Angermann committed
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
    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