88b5bad91123242f5d1690d24b393a52aa2351bf
[ghc.git] / hadrian / src / Hadrian / Utilities.hs
1 {-# LANGUAGE TypeFamilies #-}
2 module Hadrian.Utilities (
3 -- * List manipulation
4 fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize,
5
6 -- * String manipulation
7 quote, yesNo, parseYesNo, zeroOne,
8
9 -- * FilePath manipulation
10 unifyPath, (-/-),
11
12 -- * Accessing Shake's type-indexed map
13 insertExtra, lookupExtra, userSetting,
14
15 -- * Paths
16 BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
17
18 -- * File system operations
19 copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile,
20 createDirectory, copyDirectory, moveDirectory, removeDirectory,
21
22 -- * Diagnostic info
23 UseColour (..), Colour (..), ANSIColour (..), putColoured,
24 BuildProgressColour, mkBuildProgressColour, putBuild,
25 SuccessColour, mkSuccessColour, putSuccess,
26 ProgressInfo (..), putProgressInfo,
27 renderAction, renderActionNoOutput, renderProgram, renderLibrary, renderBox, renderUnicorn,
28
29 -- * Miscellaneous
30 (<&>), (%%>), cmdLineLengthLimit,
31
32 -- * Useful re-exports
33 Dynamic, fromDynamic, toDyn, TypeRep, typeOf
34 ) where
35
36 import Control.Monad.Extra
37 import Data.Char
38 import Data.Dynamic (Dynamic, fromDynamic, toDyn)
39 import Data.HashMap.Strict (HashMap)
40 import Data.List.Extra
41 import Data.Maybe
42 import Data.Typeable (TypeRep, typeOf)
43 import Development.Shake hiding (Normal)
44 import Development.Shake.Classes
45 import Development.Shake.FilePath
46 import System.Environment (lookupEnv)
47 import System.Info.Extra
48
49 import qualified Control.Exception.Base as IO
50 import qualified Data.HashMap.Strict as Map
51 import qualified System.Directory.Extra as IO
52 import qualified System.Info.Extra as IO
53 import qualified System.IO as IO
54
55 -- | Extract a value from a singleton list, or terminate with an error message
56 -- if the list does not contain exactly one value.
57 fromSingleton :: String -> [a] -> a
58 fromSingleton _ [res] = res
59 fromSingleton msg _ = error msg
60
61 -- | Find and replace all occurrences of a value in a list.
62 replaceEq :: Eq a => a -> a -> [a] -> [a]
63 replaceEq from to = map (\cur -> if cur == from then to else cur)
64
65 -- Explicit definition to avoid dependency on Data.List.Ordered
66 -- | Difference of two ordered lists.
67 minusOrd :: Ord a => [a] -> [a] -> [a]
68 minusOrd [] _ = []
69 minusOrd xs [] = xs
70 minusOrd (x:xs) (y:ys) = case compare x y of
71 LT -> x : minusOrd xs (y:ys)
72 EQ -> minusOrd xs ys
73 GT -> minusOrd (x:xs) ys
74
75 -- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests
76 -- | Intersection of two ordered lists by a predicate.
77 intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
78 intersectOrd cmp = loop
79 where
80 loop [] _ = []
81 loop _ [] = []
82 loop (x:xs) (y:ys) = case cmp x y of
83 LT -> loop xs (y:ys)
84 EQ -> x : loop xs (y:ys)
85 GT -> loop (x:xs) ys
86
87 -- | Lookup all elements of a given sorted list in a given sorted dictionary.
88 -- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has
89 -- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|).
90 --
91 -- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3]
92 -- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list
93 lookupAll :: Ord a => [a] -> [(a, b)] -> [Maybe b]
94 lookupAll [] _ = []
95 lookupAll (_:xs) [] = Nothing : lookupAll xs []
96 lookupAll (x:xs) (y:ys) = case compare x (fst y) of
97 LT -> Nothing : lookupAll xs (y:ys)
98 EQ -> Just (snd y) : lookupAll xs (y:ys)
99 GT -> lookupAll (x:xs) ys
100
101 -- | @chunksOfSize size strings@ splits a given list of strings into chunks not
102 -- exceeding the given @size@. If that is impossible, it uses singleton chunks.
103 chunksOfSize :: Int -> [String] -> [[String]]
104 chunksOfSize n = repeatedly f
105 where
106 f xs = splitAt (max 1 $ length $ takeWhile (<= n) $ scanl1 (+) $ map length xs) xs
107
108 -- | Add single quotes around a string.
109 quote :: String -> String
110 quote s = "'" ++ s ++ "'"
111
112 -- | Pretty-print a 'Bool' as a @"YES"@ or @"NO"@ string.
113 yesNo :: Bool -> String
114 yesNo True = "YES"
115 yesNo False = "NO"
116
117 -- | Parse a 'Bool' from a @"YES"@ or @"NO"@ string. Returns @Nothing@ in case
118 -- of a parse failure.
119 parseYesNo :: String -> Maybe Bool
120 parseYesNo "YES" = Just True
121 parseYesNo "NO" = Just False
122 parseYesNo _ = Nothing
123
124 -- | Pretty-print a 'Bool' as a @"0"@ or @"1"@ string
125 zeroOne :: Bool -> String
126 zeroOne False = "0"
127 zeroOne True = "1"
128
129 -- | Normalise a path and convert all path separators to @/@, even on Windows.
130 unifyPath :: FilePath -> FilePath
131 unifyPath = toStandard . normaliseEx
132
133 -- | Combine paths with a forward slash regardless of platform.
134 (-/-) :: FilePath -> FilePath -> FilePath
135 "" -/- b = b
136 a -/- b
137 | last a == '/' = a ++ b
138 | otherwise = a ++ '/' : b
139
140 infixr 6 -/-
141
142 -- | Like Shake's '%>' but gives higher priority to longer patterns. Useful
143 -- in situations when a family of build rules, e.g. @"//*.a"@ and @"//*_p.a"@
144 -- can be matched by the same file, such as @library_p.a@. We break the tie
145 -- by preferring longer matches, which correpond to longer patterns.
146 (%%>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()
147 p %%> a = priority (fromIntegral (length p) + 1) $ p %> a
148
149 infix 1 %%>
150
151 -- | Build command lines can get very long; for example, when building the Cabal
152 -- library, they can reach 2MB! Some operating systems do not support command
153 -- lines of such length, and this function can be used to obtain a reasonable
154 -- approximation of the limit. On Windows, it is theoretically 32768 characters
155 -- (since Windows 7). In practice we use 31000 to leave some breathing space for
156 -- the builder path & name, auxiliary flags, and other overheads. On Mac OS X,
157 -- ARG_MAX is 262144, yet when using @xargs@ on OSX this is reduced by over
158 -- 20000. Hence, 200000 seems like a sensible limit. On other operating systems
159 -- we currently use the 4194304 setting.
160 cmdLineLengthLimit :: Int
161 cmdLineLengthLimit | isWindows = 31000
162 | isMac = 200000
163 | otherwise = 4194304
164
165 -- | Insert a value into Shake's type-indexed map.
166 insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
167 insertExtra value = Map.insert (typeOf value) (toDyn value)
168
169 -- | Lookup a value in Shake's type-indexed map.
170 lookupExtra :: Typeable a => a -> Map.HashMap TypeRep Dynamic -> a
171 lookupExtra defaultValue extra = fromMaybe defaultValue maybeValue
172 where
173 maybeValue = fromDynamic =<< Map.lookup (typeOf defaultValue) extra
174
175 -- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the
176 -- setting is not found, return the provided default value instead.
177 userSetting :: Typeable a => a -> Action a
178 userSetting defaultValue = do
179 extra <- shakeExtra <$> getShakeOptions
180 return $ lookupExtra defaultValue extra
181
182 -- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the
183 -- setting is not found, return the provided default value instead.
184 userSettingRules :: Typeable a => a -> Rules a
185 userSettingRules defaultValue = do
186 extra <- shakeExtra <$> getShakeOptionsRules
187 return $ lookupExtra defaultValue extra
188
189 newtype BuildRoot = BuildRoot FilePath deriving (Typeable, Eq, Show)
190
191 -- | All build results are put into the 'buildRoot' directory.
192 buildRoot :: Action FilePath
193 buildRoot = do
194 BuildRoot path <- userSetting (BuildRoot "")
195 return path
196
197 buildRootRules :: Rules FilePath
198 buildRootRules = do
199 BuildRoot path <- userSettingRules (BuildRoot "")
200 return path
201
202 -- | A version of 'fmap' with flipped arguments. Useful for manipulating values
203 -- in context, e.g. 'buildRoot', as in the example below.
204 --
205 -- @
206 -- buildRoot <&> (-/- "dir") == fmap (-/- "dir") buildRoot
207 -- @
208 (<&>) :: Functor f => f a -> (a -> b) -> f b
209 (<&>) = flip fmap
210
211 infixl 1 <&>
212
213 -- | Given a 'FilePath' to a source file, return 'True' if it is generated.
214 -- The current implementation simply assumes that a file is generated if it
215 -- lives in the 'buildRoot' directory. Since most files are not generated the
216 -- test is usually very fast.
217 isGeneratedSource :: FilePath -> Action Bool
218 isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
219
220 -- | Copy a file tracking the source. Create the target directory if missing.
221 copyFile :: FilePath -> FilePath -> Action ()
222 copyFile source target = do
223 need [source] -- Guarantee the source is built before printing progress info.
224 let dir = takeDirectory target
225 liftIO $ IO.createDirectoryIfMissing True dir
226 putProgressInfo =<< renderAction "Copy file" source target
227 quietly $ copyFileChanged source target
228
229 -- | Copy a file without tracking the source. Create the target directory if missing.
230 copyFileUntracked :: FilePath -> FilePath -> Action ()
231 copyFileUntracked source target = do
232 let dir = takeDirectory target
233 liftIO $ IO.createDirectoryIfMissing True dir
234 putProgressInfo =<< renderAction "Copy file (untracked)" source target
235 liftIO $ IO.copyFile source target
236
237 -- | Transform a given file by applying a function to its contents.
238 fixFile :: FilePath -> (String -> String) -> Action ()
239 fixFile file f = do
240 putProgressInfo $ "| Fix " ++ file
241 contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do
242 old <- IO.hGetContents h
243 let new = f old
244 IO.evaluate $ rnf new
245 return new
246 liftIO $ writeFile file contents
247
248 -- | Make a given file executable by running the @chmod +x@ command.
249 makeExecutable :: FilePath -> Action ()
250 makeExecutable file = do
251 putProgressInfo $ "| Make " ++ quote file ++ " executable."
252 quietly $ cmd "chmod +x " [file]
253
254 -- | Move a file. Note that we cannot track the source, because it is moved.
255 moveFile :: FilePath -> FilePath -> Action ()
256 moveFile source target = do
257 putProgressInfo =<< renderAction "Move file" source target
258 quietly $ cmd ["mv", source, target]
259
260 -- | Remove a file that doesn't necessarily exist.
261 removeFile :: FilePath -> Action ()
262 removeFile file = do
263 putProgressInfo $ "| Remove file " ++ file
264 liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file
265
266 -- | Create a directory if it does not already exist.
267 createDirectory :: FilePath -> Action ()
268 createDirectory dir = do
269 putProgressInfo $ "| Create directory " ++ dir
270 liftIO $ IO.createDirectoryIfMissing True dir
271
272 -- | Copy a directory. The contents of the source directory is untracked.
273 copyDirectory :: FilePath -> FilePath -> Action ()
274 copyDirectory source target = do
275 putProgressInfo =<< renderAction "Copy directory" source target
276 quietly $ cmd ["cp", "-r", source, target]
277
278 -- | Move a directory. The contents of the source directory is untracked.
279 moveDirectory :: FilePath -> FilePath -> Action ()
280 moveDirectory source target = do
281 putProgressInfo =<< renderAction "Move directory" source target
282 quietly $ cmd ["mv", source, target]
283
284 -- | Remove a directory that doesn't necessarily exist.
285 removeDirectory :: FilePath -> Action ()
286 removeDirectory dir = do
287 putProgressInfo $ "| Remove directory " ++ dir
288 liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir
289
290 data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable)
291
292 -- | Terminal output colours
293 data Colour
294 = Dull ANSIColour -- ^ 8-bit ANSI colours
295 | Vivid ANSIColour -- ^ 16-bit vivid ANSI colours
296 | Extended String -- ^ Extended 256-bit colours, manual code stored
297
298 -- | ANSI terminal colours
299 data ANSIColour
300 = Black -- ^ ANSI code: 30
301 | Red -- ^ 31
302 | Green -- ^ 32
303 | Yellow -- ^ 33
304 | Blue -- ^ 34
305 | Magenta -- ^ 35
306 | Cyan -- ^ 36
307 | White -- ^ 37
308 | Reset -- ^ 0
309
310 -- | Convert ANSI colour names into their associated codes
311 colourCode :: ANSIColour -> String
312 colourCode Black = "30"
313 colourCode Red = "31"
314 colourCode Green = "32"
315 colourCode Yellow = "33"
316 colourCode Blue = "34"
317 colourCode Magenta = "35"
318 colourCode Cyan = "36"
319 colourCode White = "37"
320 colourCode Reset = "0"
321
322 -- | Create the final ANSI code.
323 mkColour :: Colour -> String
324 mkColour (Dull c) = colourCode c
325 mkColour (Vivid c) = colourCode c ++ ";1"
326 mkColour (Extended code) = "38;5;" ++ code
327
328 -- | A more colourful version of Shake's 'putNormal'.
329 putColoured :: String -> String -> Action ()
330 putColoured code msg = do
331 useColour <- userSetting Never
332 supported <- liftIO $ (&&) <$> IO.hIsTerminalDevice IO.stdout
333 <*> (not <$> isDumb)
334 let c Never = False
335 c Auto = supported || IO.isWindows -- Colours do work on Windows
336 c Always = True
337 if c useColour
338 then putNormal $ "\ESC[" ++ code ++ "m" ++ msg ++ "\ESC[0m"
339 else putNormal msg
340 where
341 isDumb = maybe False (== "dumb") <$> lookupEnv "TERM"
342
343 newtype BuildProgressColour = BuildProgressColour String
344 deriving Typeable
345
346 -- | Generate an encoded colour for progress output from names.
347 mkBuildProgressColour :: Colour -> BuildProgressColour
348 mkBuildProgressColour c = BuildProgressColour $ mkColour c
349
350 -- | Default 'BuildProgressColour'.
351 magenta :: BuildProgressColour
352 magenta = mkBuildProgressColour (Dull Magenta)
353
354 -- | Print a build progress message (e.g. executing a build command).
355 putBuild :: String -> Action ()
356 putBuild msg = do
357 BuildProgressColour code <- userSetting magenta
358 putColoured code msg
359
360 newtype SuccessColour = SuccessColour String
361 deriving Typeable
362
363 -- | Generate an encoded colour for successful output from names
364 mkSuccessColour :: Colour -> SuccessColour
365 mkSuccessColour c = SuccessColour $ mkColour c
366
367 -- | Default 'SuccessColour'.
368 green :: SuccessColour
369 green = mkSuccessColour (Dull Green)
370
371 -- | Print a success message (e.g. a package is built successfully).
372 putSuccess :: String -> Action ()
373 putSuccess msg = do
374 SuccessColour code <- userSetting green
375 putColoured code msg
376
377 data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable)
378
379 -- | Version of 'putBuild' controlled by @--progress-info@ command line argument.
380 putProgressInfo :: String -> Action ()
381 putProgressInfo msg = do
382 progressInfo <- userSetting None
383 when (progressInfo /= None) $ putBuild msg
384
385 -- | Render an action.
386 renderAction :: String -> FilePath -> FilePath -> Action String
387 renderAction what input output = do
388 progressInfo <- userSetting Brief
389 return $ case progressInfo of
390 None -> ""
391 Brief -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
392 Normal -> renderBox [ what, " input: " ++ i, " => output: " ++ o ]
393 Unicorn -> renderUnicorn [ what, " input: " ++ i, " => output: " ++ o ]
394 where
395 i = unifyPath input
396 o = unifyPath output
397
398 -- | Render an action.
399 renderActionNoOutput :: String -> FilePath -> Action String
400 renderActionNoOutput what input = do
401 progressInfo <- userSetting Brief
402 return $ case progressInfo of
403 None -> ""
404 Brief -> "| " ++ what ++ ": " ++ i
405 Normal -> renderBox [ what, " input: " ++ i ]
406 Unicorn -> renderUnicorn [ what, " input: " ++ i ]
407 where
408 i = unifyPath input
409
410 -- | Render the successful build of a program.
411 renderProgram :: String -> String -> String -> String
412 renderProgram name bin synopsis = renderBox $
413 [ "Successfully built program " ++ name
414 , "Executable: " ++ bin ] ++
415 [ "Program synopsis: " ++ endWithADot synopsis | not (null synopsis) ]
416
417 -- | Render the successful build of a library.
418 renderLibrary :: String -> String -> String -> String
419 renderLibrary name lib synopsis = renderBox $
420 [ "Successfully built library " ++ name
421 , "Library: " ++ lib ] ++
422 [ "Library synopsis: " ++ endWithADot synopsis | not (null synopsis) ]
423
424 endWithADot :: String -> String
425 endWithADot s = dropWhileEnd isPunctuation s ++ "."
426
427 -- | Render the given set of lines in an ASCII box. The minimum width and
428 -- whether to use Unicode symbols are hardcoded in the function's body.
429 --
430 -- >>> renderBox (words "lorem ipsum")
431 -- /----------\
432 -- | lorem |
433 -- | ipsum |
434 -- \----------/
435 renderBox :: [String] -> String
436 renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
437 where
438 -- Minimum total width of the box in characters
439 minimumBoxWidth = 32
440
441 -- TODO: Make this setting configurable? Setting to True by default seems
442 -- to work poorly with many fonts.
443 useUnicode = False
444
445 -- Characters to draw the box
446 (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
447 | useUnicode = ('', '', '', '', '', '', ' ')
448 | otherwise = ('-', '|', '/', '\\', '\\', '/', ' ')
449
450 -- Box width, taking minimum desired length and content into account.
451 -- The -4 is for the beginning and end pipe/padding symbols, as
452 -- in "| xxx |".
453 boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
454 where
455 maxContentLength = maximum (map length ls)
456
457 renderLine l = concat
458 [ [pipe, padding]
459 , padToLengthWith boxContentWidth padding l
460 , [padding, pipe] ]
461 where
462 padToLengthWith n filler x = x ++ replicate (n - length x) filler
463
464 (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
465 , botLeft : dashes ++ [botRight] )
466 where
467 -- +1 for each non-dash (= corner) char
468 dashes = replicate (boxContentWidth + 2) dash
469
470 -- | Render the given set of lines next to our favorite unicorn Robert.
471 renderUnicorn :: [String] -> String
472 renderUnicorn ls =
473 unlines $ take (max (length ponyLines) (length boxLines)) $
474 zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
475 where
476 ponyLines :: [String]
477 ponyLines = [ " ,;,,;'"
478 , " ,;;'( Robert the spitting unicorn"
479 , " __ ,;;' ' \\ wants you to know"
480 , " /' '\\'~~'~' \\ /'\\.) that a task "
481 , " ,;( ) / |. / just finished! "
482 , " ,;' \\ /-.,,( ) \\ "
483 , " ^ ) / ) / )| Almost there! "
484 , " || || \\) "
485 , " (_\\ (_\\ " ]
486 ponyPadding :: String
487 ponyPadding = " "
488 boxLines :: [String]
489 boxLines = ["", "", ""] ++ (lines . renderBox $ ls)