Clean up imports
[hadrian.git] / src / Utilities.hs
1 module Utilities (
2 build, buildWithCmdOptions, buildWithResources, copyFile, fixFile, moveFile,
3 removeFile, copyDirectory, copyDirectoryContents, createDirectory,
4 moveDirectory, removeDirectory, applyPatch, runBuilder, runBuilderWith,
5 makeExecutable, renderProgram, renderLibrary, builderEnvironment,
6 needBuilder, copyFileUntracked, installDirectory, installData, installScript,
7 installProgram, linkSymbolic, bashPath, contextDependencies, pkgDependencies,
8 libraryTargets, needLibrary, topsortPackages
9 ) where
10
11 import qualified System.Directory.Extra as IO
12 import qualified System.IO as IO
13 import qualified Control.Exception.Base as IO
14
15 import Hadrian.Oracles.ArgsHash
16 import Hadrian.Oracles.DirectoryContents
17 import Hadrian.Oracles.KeyValue
18 import Hadrian.Oracles.Path
19
20 import CmdLineFlag
21 import Context
22 import Expression hiding (builder, inputs, outputs, way, stage, package)
23 import GHC
24 import Oracles.Setting
25 import Oracles.PackageData
26 import Settings
27 import Settings.Path
28 import Settings.Builders.Ar
29 import Target
30 import UserSettings
31
32 -- | Build a 'Target' with the right 'Builder' and command line arguments.
33 -- Force a rebuild if the argument list has changed since the last build.
34 build :: Target -> Action ()
35 build = customBuild [] []
36
37 -- | Build a 'Target' with the right 'Builder' and command line arguments,
38 -- acquiring necessary resources. Force a rebuild if the argument list has
39 -- changed since the last build.
40 buildWithResources :: [(Resource, Int)] -> Target -> Action ()
41 buildWithResources rs = customBuild rs []
42
43 -- | Build a 'Target' with the right 'Builder' and command line arguments,
44 -- using given options when executing the build command. Force a rebuild if
45 -- the argument list has changed since the last build.
46 buildWithCmdOptions :: [CmdOption] -> Target -> Action ()
47 buildWithCmdOptions = customBuild []
48
49 customBuild :: [(Resource, Int)] -> [CmdOption] -> Target -> Action ()
50 customBuild rs opts target = do
51 let targetBuilder = builder target
52 needBuilder targetBuilder
53 path <- builderPath targetBuilder
54 argList <- interpret target getArgs
55 verbose <- interpret target verboseCommands
56 let quietlyUnlessVerbose = if verbose then withVerbosity Loud else quietly
57 trackArgsHash target -- Rerun the rule if the hash of argList has changed.
58 withResources rs $ do
59 putInfo target
60 quietlyUnlessVerbose $ case targetBuilder of
61 Ar _ -> do
62 output <- interpret target getOutput
63 if "//*.a" ?== output
64 then arCmd path argList
65 else do
66 input <- interpret target getInput
67 top <- topDirectory
68 cmd cmdEcho [Cwd output] [path] "x" (top -/- input)
69
70 Configure dir -> do
71 -- Inject /bin/bash into `libtool`, instead of /bin/sh, otherwise Windows breaks.
72 -- TODO: Figure out why.
73 bash <- bashPath
74 let env = AddEnv "CONFIG_SHELL" bash
75 cmd Shell cmdEcho env [Cwd dir] [path] opts argList
76
77 HsCpp -> captureStdout target path argList
78 GenApply -> captureStdout target path argList
79
80 GenPrimopCode -> do
81 src <- interpret target getInput
82 file <- interpret target getOutput
83 input <- readFile' src
84 Stdout output <- cmd (Stdin input) [path] argList
85 writeFileChanged file output
86
87 Make dir -> cmd Shell cmdEcho path ["-C", dir] argList
88
89 _ -> cmd cmdEcho [path] argList
90
91 -- | Suppress build output depending on the @--progress-info@ flag.
92 cmdEcho :: CmdOption
93 cmdEcho = EchoStdout $ cmdProgressInfo `elem` [Normal, Unicorn]
94
95 -- | Run a builder, capture the standard output, and write it to a given file.
96 captureStdout :: Target -> FilePath -> [String] -> Action ()
97 captureStdout target path argList = do
98 file <- interpret target getOutput
99 Stdout output <- cmd [path] argList
100 writeFileChanged file output
101
102 -- | Copy a file tracking the source, create the target directory if missing.
103 copyFile :: FilePath -> FilePath -> Action ()
104 copyFile source target = do
105 need [source] -- Guarantee source is built before printing progress info.
106 let dir = takeDirectory target
107 liftIO $ IO.createDirectoryIfMissing True dir
108 putProgressInfo $ renderAction "Copy file" source target
109 copyFileChanged source target
110
111 -- | Copy a file without tracking the source, create the target directory if missing.
112 copyFileUntracked :: FilePath -> FilePath -> Action ()
113 copyFileUntracked source target = do
114 let dir = takeDirectory target
115 liftIO $ IO.createDirectoryIfMissing True dir
116 putProgressInfo $ renderAction "Copy file (Untracked)" source target
117 liftIO $ IO.copyFile source target
118
119 -- | Move a file; we cannot track the source, because it is moved.
120 moveFile :: FilePath -> FilePath -> Action ()
121 moveFile source target = do
122 putProgressInfo $ renderAction "Move file" source target
123 quietly $ cmd ["mv", source, target]
124
125 -- | Remove a file that doesn't necessarily exist.
126 removeFile :: FilePath -> Action ()
127 removeFile file = do
128 putBuild $ "| Remove file " ++ file
129 liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file
130
131 -- | Create a directory if it does not already exist.
132 createDirectory :: FilePath -> Action ()
133 createDirectory dir = do
134 putBuild $ "| Create directory " ++ dir
135 liftIO $ IO.createDirectoryIfMissing True dir
136
137 -- | Remove a directory that doesn't necessarily exist.
138 removeDirectory :: FilePath -> Action ()
139 removeDirectory dir = do
140 putBuild $ "| Remove directory " ++ dir
141 liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir
142
143 -- | Copy a directory. The contents of the source directory is untracked.
144 copyDirectory :: FilePath -> FilePath -> Action ()
145 copyDirectory source target = do
146 putProgressInfo $ renderAction "Copy directory" source target
147 quietly $ cmd ["cp", "-r", source, target]
148
149 -- | Copy the contents of the source directory that matches a given 'Match'
150 -- expression into the target directory. The copied contents is tracked.
151 copyDirectoryContents :: Match -> FilePath -> FilePath -> Action ()
152 copyDirectoryContents expr source target = do
153 putProgressInfo $ renderAction "Copy directory contents" source target
154 let cp file = copyFile file $ target -/- makeRelative source file
155 mapM_ cp =<< directoryContents expr source
156
157 -- | Move a directory. The contents of the source directory is untracked.
158 moveDirectory :: FilePath -> FilePath -> Action ()
159 moveDirectory source target = do
160 putProgressInfo $ renderAction "Move directory" source target
161 quietly $ cmd ["mv", source, target]
162
163 -- | Transform a given file by applying a function to its contents.
164 fixFile :: FilePath -> (String -> String) -> Action ()
165 fixFile file f = do
166 putBuild $ "| Fix " ++ file
167 contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do
168 old <- IO.hGetContents h
169 let new = f old
170 IO.evaluate $ rnf new
171 return new
172 liftIO $ writeFile file contents
173
174 -- | Apply a patch by executing the 'Patch' builder in a given directory.
175 applyPatch :: FilePath -> FilePath -> Action ()
176 applyPatch dir patch = do
177 let file = dir -/- patch
178 needBuilder Patch
179 path <- builderPath Patch
180 putBuild $ "| Apply patch " ++ file
181 quietly $ cmd Shell [Cwd dir] [path, "-p0 <", patch]
182
183 -- | Install a directory.
184 installDirectory :: FilePath -> Action ()
185 installDirectory dir = do
186 path <- fixAbsolutePathOnWindows =<< setting InstallDir
187 putBuild $ "| Install directory " ++ dir
188 quietly $ cmd path dir
189
190 -- | Install data files to a directory and track them.
191 installData :: [FilePath] -> FilePath -> Action ()
192 installData fs dir = do
193 path <- fixAbsolutePathOnWindows =<< setting InstallData
194 need fs
195 forM_ fs $ \f -> putBuild $ "| Install data " ++ f ++ " to " ++ dir
196 quietly $ cmd path fs dir
197
198 -- | Install an executable file to a directory and track it.
199 installProgram :: FilePath -> FilePath -> Action ()
200 installProgram f dir = do
201 path <- fixAbsolutePathOnWindows =<< setting InstallProgram
202 need [f]
203 putBuild $ "| Install program " ++ f ++ " to " ++ dir
204 quietly $ cmd path f dir
205
206 -- | Install an executable script to a directory and track it.
207 installScript :: FilePath -> FilePath -> Action ()
208 installScript f dir = do
209 path <- fixAbsolutePathOnWindows =<< setting InstallScript
210 need [f]
211 putBuild $ "| Install script " ++ f ++ " to " ++ dir
212 quietly $ cmd path f dir
213
214 -- | Create a symbolic link from source file to target file (when symbolic links
215 -- are supported) and track the source file.
216 linkSymbolic :: FilePath -> FilePath -> Action ()
217 linkSymbolic source target = do
218 lns <- setting LnS
219 unless (null lns) $ do
220 need [source] -- Guarantee source is built before printing progress info.
221 let dir = takeDirectory target
222 liftIO $ IO.createDirectoryIfMissing True dir
223 putProgressInfo $ renderAction "Create symbolic link" source target
224 quietly $ cmd lns source target
225
226 isInternal :: Builder -> Bool
227 isInternal = isJust . builderProvenance
228
229 -- | Make sure a 'Builder' exists and rebuild it if out of date.
230 needBuilder :: Builder -> Action ()
231 needBuilder (Configure dir) = need [dir -/- "configure"]
232 needBuilder (Make dir) = need [dir -/- "Makefile"]
233 needBuilder builder = when (isInternal builder) $ do
234 path <- builderPath builder
235 need [path]
236
237 -- | Write a Builder's path into a given environment variable.
238 builderEnvironment :: String -> Builder -> Action CmdOption
239 builderEnvironment variable builder = do
240 needBuilder builder
241 path <- builderPath builder
242 return $ AddEnv variable path
243
244 runBuilder :: Builder -> [String] -> Action ()
245 runBuilder = runBuilderWith []
246
247 -- | Run a builder with given list of arguments using custom 'cmd' options.
248 runBuilderWith :: [CmdOption] -> Builder -> [String] -> Action ()
249 runBuilderWith options builder args = do
250 needBuilder builder
251 path <- builderPath builder
252 let note = if null args then "" else " (" ++ intercalate ", " args ++ ")"
253 putBuild $ "| Run " ++ show builder ++ note
254 quietly $ cmd options [path] args
255
256 -- | Make a given file executable by running the @chmod@ command.
257 makeExecutable :: FilePath -> Action ()
258 makeExecutable file = do
259 putBuild $ "| Make " ++ quote file ++ " executable."
260 quietly $ cmd "chmod +x " [file]
261
262 -- | Lookup the path to the @bash@ interpreter.
263 bashPath :: Action FilePath
264 bashPath = lookupInPath "bash"
265
266 -- | Given a 'Context' this 'Action' looks up its package dependencies in
267 -- 'Settings.Paths.packageDependencies' and wraps the results in appropriate
268 -- contexts. The only subtlety here is that we never depend on packages built in
269 -- 'Stage2' or later, therefore the stage of the resulting dependencies is
270 -- bounded from above at 'Stage1'. To compute package dependencies we scan
271 -- package cabal files, see "Rules.Cabal".
272 contextDependencies :: Context -> Action [Context]
273 contextDependencies Context {..} = do
274 let pkgContext = \pkg -> Context (min stage Stage1) pkg way
275 deps <- lookupValuesOrError packageDependencies (pkgNameString package)
276 pkgs <- sort <$> interpretInContext (pkgContext package) getPackages
277 return . map pkgContext $ intersectOrd (compare . pkgNameString) pkgs deps
278
279 -- | Lookup dependencies of a 'Package' in the vanilla Stage1 context.
280 pkgDependencies :: Package -> Action [Package]
281 pkgDependencies = fmap (map Context.package) . contextDependencies . vanillaContext Stage1
282
283 -- | Given a library 'Package' this action computes all of its targets.
284 libraryTargets :: Context -> Action [FilePath]
285 libraryTargets context = do
286 confFile <- pkgConfFile context
287 libFile <- pkgLibraryFile context
288 lib0File <- pkgLibraryFile0 context
289 lib0 <- buildDll0 context
290 ghciLib <- pkgGhciLibraryFile context
291 ghciFlag <- interpretInContext context $ getPkgData BuildGhciLib
292 let ghci = ghciFlag == "YES" && (stage context == Stage1 || stage1Only)
293 return $ [ confFile, libFile ] ++ [ lib0File | lib0 ] ++ [ ghciLib | ghci ]
294
295 -- | Coarse-grain 'need': make sure all given libraries are fully built.
296 needLibrary :: [Context] -> Action ()
297 needLibrary cs = need =<< concatMapM libraryTargets cs
298
299 -- HACK (izgzhen), see https://github.com/snowleopard/hadrian/issues/344.
300 -- | Topological sort of packages according to their dependencies.
301 topsortPackages :: [Package] -> Action [Package]
302 topsortPackages pkgs = do
303 elems <- mapM (\p -> (p,) <$> pkgDependencies p) pkgs
304 return $ map fst $ topSort elems
305 where
306 annotateInDeg es e =
307 (foldr (\e' s -> if fst e' `elem` snd e then s + 1 else s) (0 :: Int) es, e)
308 topSort [] = []
309 topSort es =
310 let annotated = map (annotateInDeg es) es
311 inDegZero = map snd $ filter ((== 0). fst) annotated
312 in inDegZero ++ topSort (es \\ inDegZero)
313
314 -- | Print out information about the command being executed.
315 putInfo :: Target -> Action ()
316 putInfo t = putProgressInfo $ renderAction
317 ("Run " ++ show (builder t) ++ contextInfo)
318 (digest $ inputs t)
319 (digest $ outputs t)
320 where
321 contextInfo = concat $ [ " (" ]
322 ++ [ "stage = " ++ show (stage $ context t) ]
323 ++ [ ", package = " ++ pkgNameString (package $ context t) ]
324 ++ [ ", way = " ++ show (way $ context t) | (way $ context t) /= vanilla ]
325 ++ [ ")" ]
326 digest [] = "none"
327 digest [x] = x
328 digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
329
330 -- | Version of @putBuild@ controlled by @progressInfo@ command line flag.
331 putProgressInfo :: String -> Action ()
332 putProgressInfo msg = when (cmdProgressInfo /= None) $ putBuild msg
333
334 -- | Render an action.
335 renderAction :: String -> FilePath -> FilePath -> String
336 renderAction what input output = case cmdProgressInfo of
337 Normal -> renderBox [ what, " input: " ++ i, " => output: " ++ o ]
338 Brief -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
339 Unicorn -> renderUnicorn [ what, " input: " ++ i, " => output: " ++ o ]
340 None -> ""
341 where
342 i = unifyPath input
343 o = unifyPath output
344
345 -- | Render the successful build of a program
346 renderProgram :: String -> String -> String -> String
347 renderProgram name bin synopsis = renderBox [ "Successfully built program " ++ name
348 , "Executable: " ++ bin
349 , "Program synopsis: " ++ synopsis ++ "."]
350
351 -- | Render the successful built of a library
352 renderLibrary :: String -> String -> String -> String
353 renderLibrary name lib synopsis = renderBox [ "Successfully built library " ++ name
354 , "Library: " ++ lib
355 , "Library synopsis: " ++ synopsis ++ "."]
356
357 -- | Render the given set of lines next to our favorit unicorn Robert.
358 renderUnicorn :: [String] -> String
359 renderUnicorn ls =
360 unlines $ take (max (length ponyLines) (length boxLines)) $
361 zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
362 where
363 ponyLines :: [String]
364 ponyLines = [ " ,;,,;'"
365 , " ,;;'( Robert the spitting unicorn"
366 , " __ ,;;' ' \\ wants you to know"
367 , " /' '\\'~~'~' \\ /'\\.) that a task "
368 , " ,;( ) / |. / just finished! "
369 , " ,;' \\ /-.,,( ) \\ "
370 , " ^ ) / ) / )| Almost there! "
371 , " || || \\) "
372 , " (_\\ (_\\ " ]
373 ponyPadding :: String
374 ponyPadding = " "
375 boxLines :: [String]
376 boxLines = ["", "", ""] ++ (lines . renderBox $ ls)
377
378 -- | Render the given set of lines in a nice box of ASCII.
379 --
380 -- The minimum width and whether to use Unicode symbols are hardcoded in the
381 -- function's body.
382 --
383 -- >>> renderBox (words "lorem ipsum")
384 -- /----------\
385 -- | lorem |
386 -- | ipsum |
387 -- \----------/
388 renderBox :: [String] -> String
389 renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
390 where
391 -- Minimum total width of the box in characters
392 minimumBoxWidth = 32
393
394 -- TODO: Make this setting configurable? Setting to True by default seems
395 -- to work poorly with many fonts.
396 useUnicode = False
397
398 -- Characters to draw the box
399 (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
400 | useUnicode = ('', '', '', '', '', '', ' ')
401 | otherwise = ('-', '|', '/', '\\', '\\', '/', ' ')
402
403 -- Box width, taking minimum desired length and content into account.
404 -- The -4 is for the beginning and end pipe/padding symbols, as
405 -- in "| xxx |".
406 boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
407 where
408 maxContentLength = maximum (map length ls)
409
410 renderLine l = concat
411 [ [pipe, padding]
412 , padToLengthWith boxContentWidth padding l
413 , [padding, pipe] ]
414 where
415 padToLengthWith n filler x = x ++ replicate (n - length x) filler
416
417 (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
418 , botLeft : dashes ++ [botRight] )
419 where
420 -- +1 for each non-dash (= corner) char
421 dashes = replicate (boxContentWidth + 2) dash