Util.hs 12.3 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,
Zhen Zhang's avatar
Zhen Zhang committed
6
    needBuilder, copyFileUntracked
7
8
    ) where

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

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

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

            Configure dir -> do
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

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

80
81
            _  -> cmd [path] argList

82
83
84
cmdEcho :: CmdOption
cmdEcho = EchoStdout $ cmdProgressInfo `elem` [Normal, Unicorn]

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

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

Zhen Zhang's avatar
Zhen Zhang committed
101
102
103
104
105
106
107
108
-- 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
109
-- | Move a file; we cannot track the source, because it is moved.
110
111
112
113
moveFile :: FilePath -> FilePath -> Action ()
moveFile source target = do
    putProgressInfo $ renderAction "Move file" source target
    liftIO $ IO.renameFile source target
114

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

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

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

Andrey Mokhov's avatar
Andrey Mokhov committed
139
140
141
142
143
144
145
-- | 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
146

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

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

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

172
173
174
175
176
177
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"]
178
needBuilder (Make      dir) = need [dir -/- "Makefile"]
179
180
181
182
183
184
185
186
187
188
189
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

190
runBuilder :: Builder -> [String] -> Action ()
kaiha's avatar
kaiha committed
191
runBuilder = runBuilderWith []
192
193
194

runBuilderWith :: [CmdOption] -> Builder -> [String] -> Action ()
runBuilderWith options builder args = do
195
    needBuilder builder
196
    path <- builderPath builder
197
    let note = if null args then "" else " (" ++ intercalate ", " args ++ ")"
198
    putBuild $ "| Run " ++ show builder ++ note
199
    quietly $ cmd options [path] args
200

201
202
makeExecutable :: FilePath -> Action ()
makeExecutable file = do
Andrey Mokhov's avatar
Andrey Mokhov committed
203
    putBuild $ "| Make " ++ quote file ++ " executable."
204
205
    quietly $ cmd "chmod +x " [file]

Andrey Mokhov's avatar
Andrey Mokhov committed
206
-- | Print out information about the command being executed.
207
208
209
putInfo :: Target -> Action ()
putInfo Target {..} = putProgressInfo $ renderAction
    ("Run " ++ show builder ++ contextInfo) (digest inputs) (digest outputs)
Andrey Mokhov's avatar
Andrey Mokhov committed
210
  where
211
212
213
214
215
    contextInfo = concat $ [ " (" ]
        ++ [ "stage = "     ++ show (stage context) ]
        ++ [ ", package = " ++ pkgNameString (package context) ]
        ++ [ ", way = "     ++ show (way context) | way context /= vanilla ]
        ++ [ ")" ]
216
217
218
    digest [] = "none"
    digest [x] = x
    digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
Moritz Angermann's avatar
Moritz Angermann committed
219

220
-- | Version of @putBuild@ controlled by @progressInfo@ command line flag.
Moritz Angermann's avatar
Moritz Angermann committed
221
putProgressInfo :: String -> Action ()
222
putProgressInfo msg = when (cmdProgressInfo /= None) $ putBuild msg
Moritz Angermann's avatar
Moritz Angermann committed
223
224

-- | Render an action.
225
renderAction :: String -> FilePath -> FilePath -> String
226
renderAction what input output = case cmdProgressInfo of
227
228
229
    Normal  -> renderBox [ what, "     input: " ++ i, " => output: " ++ o ]
    Brief   -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
    Unicorn -> renderUnicorn [ what, "     input: " ++ i, " => output: " ++ o ]
230
    None    -> ""
231
232
233
  where
    i = unifyPath input
    o = unifyPath output
Moritz Angermann's avatar
Moritz Angermann committed
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
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283

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

284
285
    -- TODO: Make this setting configurable? Setting to True by default seems
    -- to work poorly with many fonts.
Moritz Angermann's avatar
Moritz Angermann committed
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
    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