c2335c2f0b9514265dce5f971ad45bd69e9eaaf2
[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 forM_ fs $ \f ->
188 putBuild $ "| Install data " ++ f ++ " to " ++ dir
189 quietly $ cmd i fs dir
190
191 -- | Install executable file to a directory
192 installProgram :: FilePath -> FilePath -> Action ()
193 installProgram f dir = do
194 i <- setting InstallProgram
195 putBuild $ "| Install program " ++ f ++ " to " ++ dir
196 quietly $ cmd i f dir
197
198 -- | Install executable script to a directory
199 installScript :: FilePath -> FilePath -> Action ()
200 installScript f dir = do
201 i <- setting InstallScript
202 putBuild $ "| Install script " ++ f ++ " to " ++ dir
203 quietly $ cmd i f dir
204
205 -- | Create a symbolic link from source file to target file when supported
206 linkSymbolic :: FilePath -> FilePath -> Action ()
207 linkSymbolic source target = do
208 lns <- setting LnS
209 when (lns /= "") $ do
210 need [source] -- Guarantee source is built before printing progress info.
211 let dir = takeDirectory target
212 liftIO $ IO.createDirectoryIfMissing True dir
213 putProgressInfo $ renderAction "Create symbolic link" source target
214 quietly $ cmd lns source target
215
216 isInternal :: Builder -> Bool
217 isInternal = isJust . builderProvenance
218
219 -- | Make sure a 'Builder' exists and rebuild it if out of date.
220 needBuilder :: Builder -> Action ()
221 needBuilder (Configure dir) = need [dir -/- "configure"]
222 needBuilder (Make dir) = need [dir -/- "Makefile"]
223 needBuilder builder = when (isInternal builder) $ do
224 path <- builderPath builder
225 need [path]
226
227 -- | Write a Builder's path into a given environment variable.
228 builderEnvironment :: String -> Builder -> Action CmdOption
229 builderEnvironment variable builder = do
230 needBuilder builder
231 path <- builderPath builder
232 return $ AddEnv variable path
233
234 runBuilder :: Builder -> [String] -> Action ()
235 runBuilder = runBuilderWith []
236
237 runBuilderWith :: [CmdOption] -> Builder -> [String] -> Action ()
238 runBuilderWith options builder args = do
239 needBuilder builder
240 path <- builderPath builder
241 let note = if null args then "" else " (" ++ intercalate ", " args ++ ")"
242 putBuild $ "| Run " ++ show builder ++ note
243 quietly $ cmd options [path] args
244
245 makeExecutable :: FilePath -> Action ()
246 makeExecutable file = do
247 putBuild $ "| Make " ++ quote file ++ " executable."
248 quietly $ cmd "chmod +x " [file]
249
250 -- | Print out information about the command being executed.
251 putInfo :: Target -> Action ()
252 putInfo Target {..} = putProgressInfo $ renderAction
253 ("Run " ++ show builder ++ contextInfo) (digest inputs) (digest outputs)
254 where
255 contextInfo = concat $ [ " (" ]
256 ++ [ "stage = " ++ show (stage context) ]
257 ++ [ ", package = " ++ pkgNameString (package context) ]
258 ++ [ ", way = " ++ show (way context) | way context /= vanilla ]
259 ++ [ ")" ]
260 digest [] = "none"
261 digest [x] = x
262 digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
263
264 -- | Version of @putBuild@ controlled by @progressInfo@ command line flag.
265 putProgressInfo :: String -> Action ()
266 putProgressInfo msg = when (cmdProgressInfo /= None) $ putBuild msg
267
268 -- | Render an action.
269 renderAction :: String -> FilePath -> FilePath -> String
270 renderAction what input output = case cmdProgressInfo of
271 Normal -> renderBox [ what, " input: " ++ i, " => output: " ++ o ]
272 Brief -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
273 Unicorn -> renderUnicorn [ what, " input: " ++ i, " => output: " ++ o ]
274 None -> ""
275 where
276 i = unifyPath input
277 o = unifyPath output
278
279 -- | Render the successful build of a program
280 renderProgram :: String -> String -> String -> String
281 renderProgram name bin synopsis = renderBox [ "Successfully built program " ++ name
282 , "Executable: " ++ bin
283 , "Program synopsis: " ++ synopsis ++ "."]
284
285 -- | Render the successful built of a library
286 renderLibrary :: String -> String -> String -> String
287 renderLibrary name lib synopsis = renderBox [ "Successfully built library " ++ name
288 , "Library: " ++ lib
289 , "Library synopsis: " ++ synopsis ++ "."]
290
291 -- | Render the given set of lines next to our favorit unicorn Robert.
292 renderUnicorn :: [String] -> String
293 renderUnicorn ls =
294 unlines $ take (max (length ponyLines) (length boxLines)) $
295 zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
296 where
297 ponyLines :: [String]
298 ponyLines = [ " ,;,,;'"
299 , " ,;;'( Robert the spitting unicorn"
300 , " __ ,;;' ' \\ wants you to know"
301 , " /' '\\'~~'~' \\ /'\\.) that a task "
302 , " ,;( ) / |. / just finished! "
303 , " ,;' \\ /-.,,( ) \\ "
304 , " ^ ) / ) / )| Almost there! "
305 , " || || \\) "
306 , " (_\\ (_\\ " ]
307 ponyPadding :: String
308 ponyPadding = " "
309 boxLines :: [String]
310 boxLines = ["", "", ""] ++ (lines . renderBox $ ls)
311
312 -- | Render the given set of lines in a nice box of ASCII.
313 --
314 -- The minimum width and whether to use Unicode symbols are hardcoded in the
315 -- function's body.
316 --
317 -- >>> renderBox (words "lorem ipsum")
318 -- /----------\
319 -- | lorem |
320 -- | ipsum |
321 -- \----------/
322 renderBox :: [String] -> String
323 renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
324 where
325 -- Minimum total width of the box in characters
326 minimumBoxWidth = 32
327
328 -- TODO: Make this setting configurable? Setting to True by default seems
329 -- to work poorly with many fonts.
330 useUnicode = False
331
332 -- Characters to draw the box
333 (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
334 | useUnicode = ('', '', '', '', '', '', ' ')
335 | otherwise = ('-', '|', '/', '\\', '\\', '/', ' ')
336
337 -- Box width, taking minimum desired length and content into account.
338 -- The -4 is for the beginning and end pipe/padding symbols, as
339 -- in "| xxx |".
340 boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
341 where
342 maxContentLength = maximum (map length ls)
343
344 renderLine l = concat
345 [ [pipe, padding]
346 , padToLengthWith boxContentWidth padding l
347 , [padding, pipe] ]
348 where
349 padToLengthWith n filler x = x ++ replicate (n - length x) filler
350
351 (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
352 , botLeft : dashes ++ [botRight] )
353 where
354 -- +1 for each non-dash (= corner) char
355 dashes = replicate (boxContentWidth + 2) dash