Util.hs 11.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
6
    makeExecutable, renderProgram, renderLibrary, Match(..), builderEnvironment,
    needBuilder
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
97
    let dir = takeDirectory target
    unlessM (liftIO $ IO.doesDirectoryExist dir) $ createDirectory dir
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

Andrey Mokhov's avatar
Andrey Mokhov committed
131
132
133
134
135
136
137
-- | 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
138

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

Andrey Mokhov's avatar
Andrey Mokhov committed
145
-- | Transform a given file by applying a function to its contents.
146
147
fixFile :: FilePath -> (String -> String) -> Action ()
fixFile file f = do
148
    putBuild $ "| Fix " ++ file
Andrey Mokhov's avatar
Andrey Mokhov committed
149
150
151
152
153
154
    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
155

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

164
165
166
167
168
169
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"]
170
needBuilder (Make      dir) = need [dir -/- "Makefile"]
171
172
173
174
175
176
177
178
179
180
181
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

182
runBuilder :: Builder -> [String] -> Action ()
kaiha's avatar
kaiha committed
183
runBuilder = runBuilderWith []
184
185
186

runBuilderWith :: [CmdOption] -> Builder -> [String] -> Action ()
runBuilderWith options builder args = do
187
    needBuilder builder
188
    path <- builderPath builder
189
    let note = if null args then "" else " (" ++ intercalate ", " args ++ ")"
190
    putBuild $ "| Run " ++ show builder ++ note
191
    quietly $ cmd options [path] args
192

193
194
makeExecutable :: FilePath -> Action ()
makeExecutable file = do
Andrey Mokhov's avatar
Andrey Mokhov committed
195
    putBuild $ "| Make " ++ quote file ++ " executable."
196
197
    quietly $ cmd "chmod +x " [file]

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

212
-- | Version of @putBuild@ controlled by @progressInfo@ command line flag.
Moritz Angermann's avatar
Moritz Angermann committed
213
putProgressInfo :: String -> Action ()
214
putProgressInfo msg = when (cmdProgressInfo /= None) $ putBuild msg
Moritz Angermann's avatar
Moritz Angermann committed
215
216

-- | Render an action.
217
renderAction :: String -> FilePath -> FilePath -> String
218
renderAction what input output = case cmdProgressInfo of
219
220
221
    Normal  -> renderBox [ what, "     input: " ++ i, " => output: " ++ o ]
    Brief   -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
    Unicorn -> renderUnicorn [ what, "     input: " ++ i, " => output: " ++ o ]
222
    None    -> ""
223
224
225
  where
    i = unifyPath input
    o = unifyPath output
Moritz Angermann's avatar
Moritz Angermann committed
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
262
263
264
265
266
267
268
269
270
271
272
273
274
275

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

276
277
    -- TODO: Make this setting configurable? Setting to True by default seems
    -- to work poorly with many fonts.
Moritz Angermann's avatar
Moritz Angermann committed
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
    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