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