Util.hs 12 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
64
                    cmd [Cwd output] [path] "x" (top -/- input)

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

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

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

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

83
84
            _  -> cmd [path] argList

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

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

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

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

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

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

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

Andrey Mokhov's avatar
Andrey Mokhov committed
134
135
136
137
138
139
140
-- | 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
141

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

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

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

167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
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"]
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

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

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

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

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

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

-- | Render an action.
219
renderAction :: String -> FilePath -> FilePath -> String
220
renderAction what input output = case cmdProgressInfo of
221
222
223
    Normal  -> renderBox [ what, "     input: " ++ i, " => output: " ++ o ]
    Brief   -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
    Unicorn -> renderUnicorn [ what, "     input: " ++ i, " => output: " ++ o ]
224
    None    -> ""
225
226
227
  where
    i = unifyPath input
    o = unifyPath output
Moritz Angermann's avatar
Moritz Angermann committed
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
276
277

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

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