b775be2e89a59803266bdc7d4e441b65f5f0959d
[hadrian.git] / 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, 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, 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 -- | Pretty-print a `Bool` as a @"1"@ or @"0"@ string
118 zeroOne :: Bool -> String
119 zeroOne True = "1"
120 zeroOne False = "0"
121
122 -- | Normalise a path and convert all path separators to @/@, even on Windows.
123 unifyPath :: FilePath -> FilePath
124 unifyPath = toStandard . normaliseEx
125
126 -- | Combine paths with a forward slash regardless of platform.
127 (-/-) :: FilePath -> FilePath -> FilePath
128 "" -/- b = b
129 a -/- b
130 | last a == '/' = a ++ b
131 | otherwise = a ++ '/' : b
132
133 infixr 6 -/-
134
135 -- | Like Shake's '%>' but gives higher priority to longer patterns. Useful
136 -- in situations when a family of build rules, e.g. @"//*.a"@ and @"//*_p.a"@
137 -- can be matched by the same file, such as @library_p.a@. We break the tie
138 -- by preferring longer matches, which correpond to longer patterns.
139 (%%>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()
140 p %%> a = priority (fromIntegral (length p) + 1) $ p %> a
141
142 infix 1 %%>
143
144 -- | Build command lines can get very long; for example, when building the Cabal
145 -- library, they can reach 2MB! Some operating systems do not support command
146 -- lines of such length, and this function can be used to obtain a reasonable
147 -- approximation of the limit. On Windows, it is theoretically 32768 characters
148 -- (since Windows 7). In practice we use 31000 to leave some breathing space for
149 -- the builder path & name, auxiliary flags, and other overheads. On Mac OS X,
150 -- ARG_MAX is 262144, yet when using @xargs@ on OSX this is reduced by over
151 -- 20000. Hence, 200000 seems like a sensible limit. On other operating systems
152 -- we currently use the 4194304 setting.
153 cmdLineLengthLimit :: Int
154 cmdLineLengthLimit | isWindows = 31000
155 | isMac = 200000
156 | otherwise = 4194304
157
158 -- | Insert a value into Shake's type-indexed map.
159 insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
160 insertExtra value = Map.insert (typeOf value) (toDyn value)
161
162 -- | Lookup a value in Shake's type-indexed map.
163 lookupExtra :: Typeable a => a -> Map.HashMap TypeRep Dynamic -> a
164 lookupExtra defaultValue extra = fromMaybe defaultValue maybeValue
165 where
166 maybeValue = fromDynamic =<< Map.lookup (typeOf defaultValue) extra
167
168 -- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the
169 -- setting is not found, return the provided default value instead.
170 userSetting :: Typeable a => a -> Action a
171 userSetting defaultValue = do
172 extra <- shakeExtra <$> getShakeOptions
173 return $ lookupExtra 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 userSettingRules :: Typeable a => a -> Rules a
178 userSettingRules defaultValue = do
179 extra <- shakeExtra <$> getShakeOptionsRules
180 return $ lookupExtra defaultValue extra
181
182 newtype BuildRoot = BuildRoot FilePath deriving Typeable
183
184 -- | All build results are put into the 'buildRoot' directory.
185 buildRoot :: Action FilePath
186 buildRoot = do
187 BuildRoot path <- userSetting (BuildRoot "")
188 return path
189
190 buildRootRules :: Rules FilePath
191 buildRootRules = do
192 BuildRoot path <- userSettingRules (BuildRoot "")
193 return path
194
195 -- | A version of 'fmap' with flipped arguments. Useful for manipulating values
196 -- in context, e.g. 'buildRoot', as in the example below.
197 --
198 -- @
199 -- buildRoot <&> (-/- "dir") == fmap (-/- "dir") buildRoot
200 -- @
201 (<&>) :: Functor f => f a -> (a -> b) -> f b
202 (<&>) = flip fmap
203
204 infixl 1 <&>
205
206 -- | Given a 'FilePath' to a source file, return 'True' if it is generated.
207 -- The current implementation simply assumes that a file is generated if it
208 -- lives in the 'buildRoot' directory. Since most files are not generated the
209 -- test is usually very fast.
210 isGeneratedSource :: FilePath -> Action Bool
211 isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
212
213 -- | Copy a file tracking the source. Create the target directory if missing.
214 copyFile :: FilePath -> FilePath -> Action ()
215 copyFile source target = do
216 need [source] -- Guarantee the source is built before printing progress info.
217 let dir = takeDirectory target
218 liftIO $ IO.createDirectoryIfMissing True dir
219 putProgressInfo =<< renderAction "Copy file" source target
220 quietly $ copyFileChanged source target
221
222 -- | Copy a file without tracking the source. Create the target directory if missing.
223 copyFileUntracked :: FilePath -> FilePath -> Action ()
224 copyFileUntracked source target = do
225 let dir = takeDirectory target
226 liftIO $ IO.createDirectoryIfMissing True dir
227 putProgressInfo =<< renderAction "Copy file (untracked)" source target
228 liftIO $ IO.copyFile source target
229
230 -- | Transform a given file by applying a function to its contents.
231 fixFile :: FilePath -> (String -> String) -> Action ()
232 fixFile file f = do
233 putProgressInfo $ "| Fix " ++ file
234 contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do
235 old <- IO.hGetContents h
236 let new = f old
237 IO.evaluate $ rnf new
238 return new
239 liftIO $ writeFile file contents
240
241 -- | Make a given file executable by running the @chmod +x@ command.
242 makeExecutable :: FilePath -> Action ()
243 makeExecutable file = do
244 putProgressInfo $ "| Make " ++ quote file ++ " executable."
245 quietly $ cmd "chmod +x " [file]
246
247 -- | Move a file. Note that we cannot track the source, because it is moved.
248 moveFile :: FilePath -> FilePath -> Action ()
249 moveFile source target = do
250 putProgressInfo =<< renderAction "Move file" source target
251 quietly $ cmd ["mv", source, target]
252
253 -- | Remove a file that doesn't necessarily exist.
254 removeFile :: FilePath -> Action ()
255 removeFile file = do
256 putProgressInfo $ "| Remove file " ++ file
257 liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file
258
259 -- | Create a directory if it does not already exist.
260 createDirectory :: FilePath -> Action ()
261 createDirectory dir = do
262 putProgressInfo $ "| Create directory " ++ dir
263 liftIO $ IO.createDirectoryIfMissing True dir
264
265 -- | Copy a directory. The contents of the source directory is untracked.
266 copyDirectory :: FilePath -> FilePath -> Action ()
267 copyDirectory source target = do
268 putProgressInfo =<< renderAction "Copy directory" source target
269 quietly $ cmd ["cp", "-r", source, target]
270
271 -- | Move a directory. The contents of the source directory is untracked.
272 moveDirectory :: FilePath -> FilePath -> Action ()
273 moveDirectory source target = do
274 putProgressInfo =<< renderAction "Move directory" source target
275 quietly $ cmd ["mv", source, target]
276
277 -- | Remove a directory that doesn't necessarily exist.
278 removeDirectory :: FilePath -> Action ()
279 removeDirectory dir = do
280 putProgressInfo $ "| Remove directory " ++ dir
281 liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir
282
283 data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable)
284
285 -- | Terminal output colours
286 data Colour
287 = Dull ANSIColour -- ^ 8-bit ANSI colours
288 | Vivid ANSIColour -- ^ 16-bit vivid ANSI colours
289 | Extended String -- ^ Extended 256-bit colours, manual code stored
290
291 -- | ANSI terminal colours
292 data ANSIColour
293 = Black -- ^ ANSI code: 30
294 | Red -- ^ 31
295 | Green -- ^ 32
296 | Yellow -- ^ 33
297 | Blue -- ^ 34
298 | Magenta -- ^ 35
299 | Cyan -- ^ 36
300 | White -- ^ 37
301 | Reset -- ^ 0
302
303 -- | Convert ANSI colour names into their associated codes
304 colourCode :: ANSIColour -> String
305 colourCode Black = "30"
306 colourCode Red = "31"
307 colourCode Green = "32"
308 colourCode Yellow = "33"
309 colourCode Blue = "34"
310 colourCode Magenta = "35"
311 colourCode Cyan = "36"
312 colourCode White = "37"
313 colourCode Reset = "0"
314
315 -- | Create the final ANSI code.
316 mkColour :: Colour -> String
317 mkColour (Dull c) = colourCode c
318 mkColour (Vivid c) = colourCode c ++ ";1"
319 mkColour (Extended code) = "38;5;" ++ code
320
321 -- | A more colourful version of Shake's 'putNormal'.
322 putColoured :: String -> String -> Action ()
323 putColoured code msg = do
324 useColour <- userSetting Never
325 supported <- liftIO $ (&&) <$> IO.hIsTerminalDevice IO.stdout
326 <*> (not <$> isDumb)
327 let c Never = False
328 c Auto = supported || IO.isWindows -- Colours do work on Windows
329 c Always = True
330 if c useColour
331 then putNormal $ "\ESC[" ++ code ++ "m" ++ msg ++ "\ESC[0m"
332 else putNormal msg
333 where
334 isDumb = maybe False (== "dumb") <$> lookupEnv "TERM"
335
336 newtype BuildProgressColour = BuildProgressColour String
337 deriving Typeable
338
339 -- | Generate an encoded colour for progress output from names.
340 mkBuildProgressColour :: Colour -> BuildProgressColour
341 mkBuildProgressColour c = BuildProgressColour $ mkColour c
342
343 -- | Default 'BuildProgressColour'.
344 magenta :: BuildProgressColour
345 magenta = mkBuildProgressColour (Dull Magenta)
346
347 -- | Print a build progress message (e.g. executing a build command).
348 putBuild :: String -> Action ()
349 putBuild msg = do
350 BuildProgressColour code <- userSetting magenta
351 putColoured code msg
352
353 newtype SuccessColour = SuccessColour String
354 deriving Typeable
355
356 -- | Generate an encoded colour for successful output from names
357 mkSuccessColour :: Colour -> SuccessColour
358 mkSuccessColour c = SuccessColour $ mkColour c
359
360 -- | Default 'SuccessColour'.
361 green :: SuccessColour
362 green = mkSuccessColour (Dull Green)
363
364 -- | Print a success message (e.g. a package is built successfully).
365 putSuccess :: String -> Action ()
366 putSuccess msg = do
367 SuccessColour code <- userSetting green
368 putColoured code msg
369
370 data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable)
371
372 -- | Version of 'putBuild' controlled by @--progress-info@ command line argument.
373 putProgressInfo :: String -> Action ()
374 putProgressInfo msg = do
375 progressInfo <- userSetting None
376 when (progressInfo /= None) $ putBuild msg
377
378 -- | Render an action.
379 renderAction :: String -> FilePath -> FilePath -> Action String
380 renderAction what input output = do
381 progressInfo <- userSetting Brief
382 return $ case progressInfo of
383 None -> ""
384 Brief -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
385 Normal -> renderBox [ what, " input: " ++ i, " => output: " ++ o ]
386 Unicorn -> renderUnicorn [ what, " input: " ++ i, " => output: " ++ o ]
387 where
388 i = unifyPath input
389 o = unifyPath output
390
391 -- | Render the successful build of a program.
392 renderProgram :: String -> String -> Maybe String -> String
393 renderProgram name bin synopsis = renderBox $
394 [ "Successfully built program " ++ name
395 , "Executable: " ++ bin ] ++
396 [ "Program synopsis: " ++ prettySynopsis synopsis | isJust synopsis ]
397
398 -- | Render the successful build of a library.
399 renderLibrary :: String -> String -> Maybe String -> String
400 renderLibrary name lib synopsis = renderBox $
401 [ "Successfully built library " ++ name
402 , "Library: " ++ lib ] ++
403 [ "Library synopsis: " ++ prettySynopsis synopsis | isJust synopsis ]
404
405 prettySynopsis :: Maybe String -> String
406 prettySynopsis Nothing = ""
407 prettySynopsis (Just s) = dropWhileEnd isPunctuation s ++ "."
408
409 -- | Render the given set of lines in an ASCII box. The minimum width and
410 -- whether to use Unicode symbols are hardcoded in the function's body.
411 --
412 -- >>> renderBox (words "lorem ipsum")
413 -- /----------\
414 -- | lorem |
415 -- | ipsum |
416 -- \----------/
417 renderBox :: [String] -> String
418 renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
419 where
420 -- Minimum total width of the box in characters
421 minimumBoxWidth = 32
422
423 -- TODO: Make this setting configurable? Setting to True by default seems
424 -- to work poorly with many fonts.
425 useUnicode = False
426
427 -- Characters to draw the box
428 (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
429 | useUnicode = ('', '', '', '', '', '', ' ')
430 | otherwise = ('-', '|', '/', '\\', '\\', '/', ' ')
431
432 -- Box width, taking minimum desired length and content into account.
433 -- The -4 is for the beginning and end pipe/padding symbols, as
434 -- in "| xxx |".
435 boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
436 where
437 maxContentLength = maximum (map length ls)
438
439 renderLine l = concat
440 [ [pipe, padding]
441 , padToLengthWith boxContentWidth padding l
442 , [padding, pipe] ]
443 where
444 padToLengthWith n filler x = x ++ replicate (n - length x) filler
445
446 (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
447 , botLeft : dashes ++ [botRight] )
448 where
449 -- +1 for each non-dash (= corner) char
450 dashes = replicate (boxContentWidth + 2) dash
451
452 -- | Render the given set of lines next to our favorite unicorn Robert.
453 renderUnicorn :: [String] -> String
454 renderUnicorn ls =
455 unlines $ take (max (length ponyLines) (length boxLines)) $
456 zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
457 where
458 ponyLines :: [String]
459 ponyLines = [ " ,;,,;'"
460 , " ,;;'( Robert the spitting unicorn"
461 , " __ ,;;' ' \\ wants you to know"
462 , " /' '\\'~~'~' \\ /'\\.) that a task "
463 , " ,;( ) / |. / just finished! "
464 , " ,;' \\ /-.,,( ) \\ "
465 , " ^ ) / ) / )| Almost there! "
466 , " || || \\) "
467 , " (_\\ (_\\ " ]
468 ponyPadding :: String
469 ponyPadding = " "
470 boxLines :: [String]
471 boxLines = ["", "", ""] ++ (lines . renderBox $ ls)