Util.hs 13.9 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,
5
    makeExecutable, renderProgram, renderLibrary, Match(..), builderEnvironment,
6
7
    needBuilder, copyFileUntracked, installDir, installData, installScript,
    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

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

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

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

Andrey Mokhov's avatar
Andrey Mokhov committed
72
73
            HsCpp    -> captureStdout target path argList
            GenApply -> captureStdout target path argList
Andrey Mokhov's avatar
Andrey Mokhov committed
74

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

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

84
85
            _  -> cmd [path] argList

86
87
88
cmdEcho :: CmdOption
cmdEcho = EchoStdout $ cmdProgressInfo `elem` [Normal, Unicorn]

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

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

Zhen Zhang's avatar
Zhen Zhang committed
105
106
107
108
109
110
111
112
-- Same as copyFile, but not tracking the source as a build dependency
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
113
-- | Move a file; we cannot track the source, because it is moved.
114
115
116
117
moveFile :: FilePath -> FilePath -> Action ()
moveFile source target = do
    putProgressInfo $ renderAction "Move file" source target
    liftIO $ IO.renameFile source target
118

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

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

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

Andrey Mokhov's avatar
Andrey Mokhov committed
143
144
145
146
147
148
149
-- | 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
150

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

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

168
169
170
applyPatch :: FilePath -> FilePath -> Action ()
applyPatch dir patch = do
    let file = dir -/- patch
171
    needBuilder Patch
172
173
    path <- builderPath Patch
    putBuild $ "| Apply patch " ++ file
174
    quietly $ cmd Shell cmdEcho [Cwd dir] [path, "-p0 <", patch]
175

176
177
178
179
180
181
182
183
184
185
186
-- | Install a directory
installDir :: FilePath -> Action ()
installDir dir = do
    i <- setting InstallDir
    putBuild $ "| Install directory" ++ dir
    quietly $ cmd i dir

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

-- | Install executable file to a directory
installProgram :: FilePath -> FilePath -> Action ()
installProgram f dir = do
    i <- setting InstallProgram
196
    need [f]
197
198
199
200
201
202
203
    putBuild $ "| Install program " ++ f ++ " to " ++ dir
    quietly $ cmd i f dir

-- | Install executable script to a directory
installScript :: FilePath -> FilePath -> Action ()
installScript f dir = do
    i <- setting InstallScript
204
    need [f]
205
206
207
208
209
210
211
212
213
214
215
216
217
218
    putBuild $ "| Install script " ++ f ++ " to " ++ dir
    quietly $ cmd i f dir

-- | Create a symbolic link from source file to target file when supported
linkSymbolic :: FilePath -> FilePath -> Action ()
linkSymbolic source target = do
    lns <- setting LnS
    when (lns /= "") $ do
        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

219
220
221
222
223
224
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"]
225
needBuilder (Make      dir) = need [dir -/- "Makefile"]
226
227
228
229
230
231
232
233
234
235
236
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

237
runBuilder :: Builder -> [String] -> Action ()
kaiha's avatar
kaiha committed
238
runBuilder = runBuilderWith []
239
240
241

runBuilderWith :: [CmdOption] -> Builder -> [String] -> Action ()
runBuilderWith options builder args = do
242
    needBuilder builder
243
    path <- builderPath builder
244
    let note = if null args then "" else " (" ++ intercalate ", " args ++ ")"
245
    putBuild $ "| Run " ++ show builder ++ note
246
    quietly $ cmd options [path] args
247

248
249
makeExecutable :: FilePath -> Action ()
makeExecutable file = do
Andrey Mokhov's avatar
Andrey Mokhov committed
250
    putBuild $ "| Make " ++ quote file ++ " executable."
251
252
    quietly $ cmd "chmod +x " [file]

Andrey Mokhov's avatar
Andrey Mokhov committed
253
-- | Print out information about the command being executed.
254
255
256
putInfo :: Target -> Action ()
putInfo Target {..} = putProgressInfo $ renderAction
    ("Run " ++ show builder ++ contextInfo) (digest inputs) (digest outputs)
Andrey Mokhov's avatar
Andrey Mokhov committed
257
  where
258
259
260
261
262
    contextInfo = concat $ [ " (" ]
        ++ [ "stage = "     ++ show (stage context) ]
        ++ [ ", package = " ++ pkgNameString (package context) ]
        ++ [ ", way = "     ++ show (way context) | way context /= vanilla ]
        ++ [ ")" ]
263
264
265
    digest [] = "none"
    digest [x] = x
    digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
Moritz Angermann's avatar
Moritz Angermann committed
266

267
-- | Version of @putBuild@ controlled by @progressInfo@ command line flag.
Moritz Angermann's avatar
Moritz Angermann committed
268
putProgressInfo :: String -> Action ()
269
putProgressInfo msg = when (cmdProgressInfo /= None) $ putBuild msg
Moritz Angermann's avatar
Moritz Angermann committed
270
271

-- | Render an action.
272
renderAction :: String -> FilePath -> FilePath -> String
273
renderAction what input output = case cmdProgressInfo of
274
275
276
    Normal  -> renderBox [ what, "     input: " ++ i, " => output: " ++ o ]
    Brief   -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
    Unicorn -> renderUnicorn [ what, "     input: " ++ i, " => output: " ++ o ]
277
    None    -> ""
278
279
280
  where
    i = unifyPath input
    o = unifyPath output
Moritz Angermann's avatar
Moritz Angermann committed
281
282
283
284
285
286
287
288
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

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

331
332
    -- TODO: Make this setting configurable? Setting to True by default seems
    -- to work poorly with many fonts.
Moritz Angermann's avatar
Moritz Angermann committed
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
    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