edf98eb3c9024032aed1fdb68fb21179ad003adf
[ghc.git] / src / Rules / Actions.hs
1 module Rules.Actions (
2 build, buildWithResources, buildWithCmdOptions, copyFile, moveFile,
3 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 (EchoStdout False) [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 createDirectory :: FilePath -> Action ()
98 createDirectory dir = do
99 putBuild $ "| Create directory " ++ dir
100 liftIO $ IO.createDirectoryIfMissing True dir
101
102 removeDirectory :: FilePath -> Action ()
103 removeDirectory dir = do
104 putBuild $ "| Remove directory " ++ dir
105 removeDirectoryIfExists dir
106
107 -- Note, the source directory is untracked
108 copyDirectory :: FilePath -> FilePath -> Action ()
109 copyDirectory source target = do
110 putProgressInfo $ renderAction "Copy directory" source target
111 quietly $ cmd (EchoStdout False) ["cp", "-r", source, target]
112
113 -- Note, the source directory is untracked
114 moveDirectory :: FilePath -> FilePath -> Action ()
115 moveDirectory source target = do
116 putProgressInfo $ renderAction "Move directory" source target
117 liftIO $ IO.renameDirectory source target
118
119 -- Transform a given file by applying a function to its contents
120 fixFile :: FilePath -> (String -> String) -> Action ()
121 fixFile file f = do
122 putBuild $ "| Fix " ++ file
123 contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do
124 old <- IO.hGetContents h
125 let new = f old
126 IO.evaluate $ rnf new
127 return new
128 liftIO $ writeFile file contents
129
130 runMake :: FilePath -> [String] -> Action ()
131 runMake = runMakeWithVerbosity False
132
133 runMakeVerbose :: FilePath -> [String] -> Action ()
134 runMakeVerbose = runMakeWithVerbosity True
135
136 runMakeWithVerbosity :: Bool -> FilePath -> [String] -> Action ()
137 runMakeWithVerbosity verbose dir args = do
138 need [dir -/- "Makefile"]
139 path <- builderPath Make
140 let note = if null args then "" else " (" ++ intercalate ", " args ++ ")"
141 putBuild $ "| Run make" ++ note ++ " in " ++ dir ++ "..."
142 if verbose
143 then cmd Shell path ["-C", dir] args
144 else quietly $ cmd Shell (EchoStdout False) path ["-C", dir] args
145
146 applyPatch :: FilePath -> FilePath -> Action ()
147 applyPatch dir patch = do
148 let file = dir -/- patch
149 need [file]
150 needBuilder Patch
151 path <- builderPath Patch
152 putBuild $ "| Apply patch " ++ file
153 quietly $ cmd Shell (EchoStdout False) [Cwd dir] [path, "-p0 <", patch]
154
155 runBuilder :: Builder -> [String] -> Action ()
156 runBuilder builder args = do
157 needBuilder builder
158 path <- builderPath builder
159 let note = if null args then "" else " (" ++ intercalate ", " args ++ ")"
160 putBuild $ "| Run " ++ show builder ++ note
161 quietly $ cmd [path] args
162
163 makeExecutable :: FilePath -> Action ()
164 makeExecutable file = do
165 putBuild $ "| Make '" ++ file ++ "' executable."
166 quietly $ cmd "chmod +x " [file]
167
168 -- Print out key information about the command being executed
169 putInfo :: Target -> Action ()
170 putInfo Target {..} = putProgressInfo $ renderAction
171 ("Run " ++ show builder ++ contextInfo) (digest inputs) (digest outputs)
172 where
173 contextInfo = concat $ [ " (" ]
174 ++ [ "stage = " ++ show (stage context) ]
175 ++ [ ", package = " ++ pkgNameString (package context) ]
176 ++ [ ", way = " ++ show (way context) | way context /= vanilla ]
177 ++ [ ")" ]
178 digest [] = "none"
179 digest [x] = x
180 digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
181
182 -- | Version of @putBuild@ controlled by @progressInfo@ command line flag.
183 putProgressInfo :: String -> Action ()
184 putProgressInfo msg = when (cmdProgressInfo /= None) $ putBuild msg
185
186 -- | Render an action.
187 renderAction :: String -> String -> String -> String
188 renderAction what input output = case cmdProgressInfo of
189 Normal -> renderBox [ what
190 , " input: " ++ input
191 , " => output: " ++ output ]
192 Brief -> "| " ++ what ++ ": " ++ input ++ " => " ++ output
193 Unicorn -> renderUnicorn [ what
194 , " input: " ++ input
195 , " => output: " ++ output ]
196 None -> ""
197
198 -- | Render the successful build of a program
199 renderProgram :: String -> String -> String -> String
200 renderProgram name bin synopsis = renderBox [ "Successfully built program " ++ name
201 , "Executable: " ++ bin
202 , "Program synopsis: " ++ synopsis ++ "."]
203
204 -- | Render the successful built of a library
205 renderLibrary :: String -> String -> String -> String
206 renderLibrary name lib synopsis = renderBox [ "Successfully built library " ++ name
207 , "Library: " ++ lib
208 , "Library synopsis: " ++ synopsis ++ "."]
209
210 -- | Render the given set of lines next to our favorit unicorn Robert.
211 renderUnicorn :: [String] -> String
212 renderUnicorn ls =
213 unlines $ take (max (length ponyLines) (length boxLines)) $
214 zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
215 where
216 ponyLines :: [String]
217 ponyLines = [ " ,;,,;'"
218 , " ,;;'( Robert the spitting unicorn"
219 , " __ ,;;' ' \\ wants you to know"
220 , " /' '\\'~~'~' \\ /'\\.) that a task "
221 , " ,;( ) / |. / just finished! "
222 , " ,;' \\ /-.,,( ) \\ "
223 , " ^ ) / ) / )| Almost there! "
224 , " || || \\) "
225 , " (_\\ (_\\ " ]
226 ponyPadding :: String
227 ponyPadding = " "
228 boxLines :: [String]
229 boxLines = ["", "", ""] ++ (lines . renderBox $ ls)
230
231 -- | Render the given set of lines in a nice box of ASCII.
232 --
233 -- The minimum width and whether to use Unicode symbols are hardcoded in the
234 -- function's body.
235 --
236 -- >>> renderBox (words "lorem ipsum")
237 -- /----------\
238 -- | lorem |
239 -- | ipsum |
240 -- \----------/
241 renderBox :: [String] -> String
242 renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
243 where
244 -- Minimum total width of the box in characters
245 minimumBoxWidth = 32
246
247 -- TODO: Make this setting configurable? Setting to True by default seems
248 -- to work poorly with many fonts.
249 useUnicode = False
250
251 -- Characters to draw the box
252 (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
253 | useUnicode = ('', '', '', '', '', '', ' ')
254 | otherwise = ('-', '|', '/', '\\', '\\', '/', ' ')
255
256 -- Box width, taking minimum desired length and content into account.
257 -- The -4 is for the beginning and end pipe/padding symbols, as
258 -- in "| xxx |".
259 boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
260 where
261 maxContentLength = maximum (map length ls)
262
263 renderLine l = concat
264 [ [pipe, padding]
265 , padToLengthWith boxContentWidth padding l
266 , [padding, pipe] ]
267 where
268 padToLengthWith n filler x = x ++ replicate (n - length x) filler
269
270 (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
271 , botLeft : dashes ++ [botRight] )
272 where
273 -- +1 for each non-dash (= corner) char
274 dashes = replicate (boxContentWidth + 2) dash