Show output of boot and configure.
[ghc.git] / src / Rules / Actions.hs
1 module Rules.Actions (
2 build, buildWithResources, buildWithCmdOptions, copyFile, moveFile,
3 removeFile, createDirectory, removeDirectory, copyDirectory, moveDirectory,
4 applyPatch, fixFile, runMake, runMakeVerbose, renderLibrary, renderProgram,
5 runBuilder, makeExecutable
6 ) where
7
8 import qualified System.Directory as IO
9 import qualified System.IO as IO
10 import qualified Control.Exception.Base as IO
11
12 import Base
13 import CmdLineFlag
14 import Context
15 import Expression
16 import Oracles.ArgsHash
17 import Oracles.WindowsPath
18 import Settings
19 import Settings.Args
20 import Settings.Builders.Ar
21 import Target
22
23 -- | Build a 'Target' with the right 'Builder' and command line arguments.
24 -- Force a rebuild if the argument list has changed since the last build.
25 build :: Target -> Action ()
26 build = customBuild [] []
27
28 -- | Build a 'Target' with the right 'Builder' and command line arguments,
29 -- acquiring necessary resources. Force a rebuild if the argument list has
30 -- changed since the last build.
31 buildWithResources :: [(Resource, Int)] -> Target -> Action ()
32 buildWithResources rs = customBuild rs []
33
34 -- | Build a 'Target' with the right 'Builder' and command line arguments,
35 -- using given options when executing the build command. Force a rebuild if
36 -- the argument list has changed since the last build.
37 buildWithCmdOptions :: [CmdOption] -> Target -> Action ()
38 buildWithCmdOptions = customBuild []
39
40 customBuild :: [(Resource, Int)] -> [CmdOption] -> Target -> Action ()
41 customBuild rs opts target@Target {..} = do
42 needBuilder builder
43 path <- builderPath builder
44 argList <- interpret target getArgs
45 verbose <- interpret target verboseCommands
46 let quietlyUnlessVerbose = if verbose then withVerbosity Loud else quietly
47 -- The line below forces the rule to be rerun if the args hash has changed
48 checkArgsHash target
49 withResources rs $ do
50 putInfo target
51 quietlyUnlessVerbose $ case builder of
52 Ar -> do
53 output <- interpret target getOutput
54 if "//*.a" ?== output
55 then arCmd path argList
56 else do
57 input <- interpret target getInput
58 top <- topDirectory
59 cmd [Cwd output] [path] "x" (top -/- input)
60
61 Configure dir -> do
62 need [dir -/- "configure"]
63 -- Inject /bin/bash into `libtool`, instead of /bin/sh
64 let env = AddEnv "CONFIG_SHELL" "/bin/bash"
65 cmd Shell [Cwd dir] [path] (env:opts) argList
66
67 HsCpp -> captureStdout target path argList
68 GenApply -> captureStdout target path argList
69
70 GenPrimopCode -> do
71 src <- interpret target getInput
72 file <- interpret target getOutput
73 input <- readFile' src
74 Stdout output <- cmd (Stdin input) [path] argList
75 writeFileChanged file output
76
77 _ -> cmd [path] argList
78
79 captureStdout :: Target -> FilePath -> [String] -> Action ()
80 captureStdout target path argList = do
81 file <- interpret target getOutput
82 Stdout output <- cmd [path] argList
83 writeFileChanged file output
84
85 copyFile :: FilePath -> FilePath -> Action ()
86 copyFile source target = do
87 need [source] -- Guarantee source is built before printing progress info.
88 putProgressInfo $ renderAction "Copy file" source target
89 copyFileChanged source target
90
91 -- Note, moveFile cannot track the source, because it is moved.
92 moveFile :: FilePath -> FilePath -> Action ()
93 moveFile source target = do
94 putProgressInfo $ renderAction "Move file" source target
95 liftIO $ IO.renameFile source target
96
97 -- | Remove a file that doesn't necessarily exist.
98 removeFile :: FilePath -> Action ()
99 removeFile file = do
100 putBuild $ "| Remove file " ++ file
101 liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file
102
103 createDirectory :: FilePath -> Action ()
104 createDirectory dir = do
105 putBuild $ "| Create directory " ++ dir
106 liftIO $ IO.createDirectoryIfMissing True dir
107
108 -- | Remove a directory that doesn't necessarily exist.
109 removeDirectory :: FilePath -> Action ()
110 removeDirectory dir = do
111 putBuild $ "| Remove directory " ++ dir
112 liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir
113
114 -- Note, the source directory is untracked
115 copyDirectory :: FilePath -> FilePath -> Action ()
116 copyDirectory source target = do
117 putProgressInfo $ renderAction "Copy directory" source target
118 quietly $ cmd (EchoStdout False) ["cp", "-r", source, target]
119
120 -- Note, the source directory is untracked
121 moveDirectory :: FilePath -> FilePath -> Action ()
122 moveDirectory source target = do
123 putProgressInfo $ renderAction "Move directory" source target
124 liftIO $ IO.renameDirectory source target
125
126 -- Transform a given file by applying a function to its contents
127 fixFile :: FilePath -> (String -> String) -> Action ()
128 fixFile file f = do
129 putBuild $ "| Fix " ++ file
130 contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do
131 old <- IO.hGetContents h
132 let new = f old
133 IO.evaluate $ rnf new
134 return new
135 liftIO $ writeFile file contents
136
137 runMake :: FilePath -> [String] -> Action ()
138 runMake = runMakeWithVerbosity False
139
140 runMakeVerbose :: FilePath -> [String] -> Action ()
141 runMakeVerbose = runMakeWithVerbosity True
142
143 runMakeWithVerbosity :: Bool -> FilePath -> [String] -> Action ()
144 runMakeWithVerbosity verbose dir args = do
145 need [dir -/- "Makefile"]
146 path <- builderPath Make
147 let note = if null args then "" else " (" ++ intercalate ", " args ++ ")"
148 putBuild $ "| Run make" ++ note ++ " in " ++ dir ++ "..."
149 if verbose
150 then cmd Shell path ["-C", dir] args
151 else quietly $ cmd Shell (EchoStdout False) path ["-C", dir] args
152
153 applyPatch :: FilePath -> FilePath -> Action ()
154 applyPatch dir patch = do
155 let file = dir -/- patch
156 needBuilder Patch
157 path <- builderPath Patch
158 putBuild $ "| Apply patch " ++ file
159 quietly $ cmd Shell (EchoStdout False) [Cwd dir] [path, "-p0 <", patch]
160
161 runBuilder :: Builder -> [String] -> Action ()
162 runBuilder builder args = do
163 needBuilder builder
164 path <- builderPath builder
165 let note = if null args then "" else " (" ++ intercalate ", " args ++ ")"
166 putBuild $ "| Run " ++ show builder ++ note
167 quietly $ cmd [path] args
168
169 makeExecutable :: FilePath -> Action ()
170 makeExecutable file = do
171 putBuild $ "| Make '" ++ file ++ "' executable."
172 quietly $ cmd "chmod +x " [file]
173
174 -- Print out key information about the command being executed
175 putInfo :: Target -> Action ()
176 putInfo Target {..} = putProgressInfo $ renderAction
177 ("Run " ++ show builder ++ contextInfo) (digest inputs) (digest outputs)
178 where
179 contextInfo = concat $ [ " (" ]
180 ++ [ "stage = " ++ show (stage context) ]
181 ++ [ ", package = " ++ pkgNameString (package context) ]
182 ++ [ ", way = " ++ show (way context) | way context /= vanilla ]
183 ++ [ ")" ]
184 digest [] = "none"
185 digest [x] = x
186 digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
187
188 -- | Version of @putBuild@ controlled by @progressInfo@ command line flag.
189 putProgressInfo :: String -> Action ()
190 putProgressInfo msg = when (cmdProgressInfo /= None) $ putBuild msg
191
192 -- | Render an action.
193 renderAction :: String -> String -> String -> String
194 renderAction what input output = case cmdProgressInfo of
195 Normal -> renderBox [ what
196 , " input: " ++ input
197 , " => output: " ++ output ]
198 Brief -> "| " ++ what ++ ": " ++ input ++ " => " ++ output
199 Unicorn -> renderUnicorn [ what
200 , " input: " ++ input
201 , " => output: " ++ output ]
202 None -> ""
203
204 -- | Render the successful build of a program
205 renderProgram :: String -> String -> String -> String
206 renderProgram name bin synopsis = renderBox [ "Successfully built program " ++ name
207 , "Executable: " ++ bin
208 , "Program synopsis: " ++ synopsis ++ "."]
209
210 -- | Render the successful built of a library
211 renderLibrary :: String -> String -> String -> String
212 renderLibrary name lib synopsis = renderBox [ "Successfully built library " ++ name
213 , "Library: " ++ lib
214 , "Library synopsis: " ++ synopsis ++ "."]
215
216 -- | Render the given set of lines next to our favorit unicorn Robert.
217 renderUnicorn :: [String] -> String
218 renderUnicorn ls =
219 unlines $ take (max (length ponyLines) (length boxLines)) $
220 zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
221 where
222 ponyLines :: [String]
223 ponyLines = [ " ,;,,;'"
224 , " ,;;'( Robert the spitting unicorn"
225 , " __ ,;;' ' \\ wants you to know"
226 , " /' '\\'~~'~' \\ /'\\.) that a task "
227 , " ,;( ) / |. / just finished! "
228 , " ,;' \\ /-.,,( ) \\ "
229 , " ^ ) / ) / )| Almost there! "
230 , " || || \\) "
231 , " (_\\ (_\\ " ]
232 ponyPadding :: String
233 ponyPadding = " "
234 boxLines :: [String]
235 boxLines = ["", "", ""] ++ (lines . renderBox $ ls)
236
237 -- | Render the given set of lines in a nice box of ASCII.
238 --
239 -- The minimum width and whether to use Unicode symbols are hardcoded in the
240 -- function's body.
241 --
242 -- >>> renderBox (words "lorem ipsum")
243 -- /----------\
244 -- | lorem |
245 -- | ipsum |
246 -- \----------/
247 renderBox :: [String] -> String
248 renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
249 where
250 -- Minimum total width of the box in characters
251 minimumBoxWidth = 32
252
253 -- TODO: Make this setting configurable? Setting to True by default seems
254 -- to work poorly with many fonts.
255 useUnicode = False
256
257 -- Characters to draw the box
258 (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
259 | useUnicode = ('', '', '', '', '', '', ' ')
260 | otherwise = ('-', '|', '/', '\\', '\\', '/', ' ')
261
262 -- Box width, taking minimum desired length and content into account.
263 -- The -4 is for the beginning and end pipe/padding symbols, as
264 -- in "| xxx |".
265 boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
266 where
267 maxContentLength = maximum (map length ls)
268
269 renderLine l = concat
270 [ [pipe, padding]
271 , padToLengthWith boxContentWidth padding l
272 , [padding, pipe] ]
273 where
274 padToLengthWith n filler x = x ++ replicate (n - length x) filler
275
276 (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
277 , botLeft : dashes ++ [botRight] )
278 where
279 -- +1 for each non-dash (= corner) char
280 dashes = replicate (boxContentWidth + 2) dash