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
import Hadrian.Oracles.ArgsHash
15
import Hadrian.Oracles.DirectoryContents
16

Ben Gamari's avatar
Ben Gamari committed
17
import Base
Andrey Mokhov's avatar
Andrey Mokhov committed
18
import CmdLineFlag
19
import Context
Andrey Mokhov's avatar
Andrey Mokhov committed
20
import Expression
21 22
import GHC
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
    trackArgsHash 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