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