.bat file tidy up plus shake-0.16 compatibility (#392)
[hadrian.git] / src / Hadrian / Utilities.hs
1 {-# LANGUAGE TypeFamilies #-}
2 module Hadrian.Utilities (
3 -- * List manipulation
4 fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll,
5
6 -- * String manipulation
7 quote, yesNo,
8
9 -- * FilePath manipulation
10 unifyPath, (-/-),
11
12 -- * Accessing Shake's type-indexed map
13 insertExtra, 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 -- * Shake compatibility
29 RuleResult,
30
31 -- * Miscellaneous
32 (<&>), (%%>),
33
34 -- * Useful re-exports
35 Dynamic, fromDynamic, toDyn, TypeRep, typeOf
36 ) where
37
38 import Control.Monad.Extra
39 import Data.Dynamic (Dynamic, fromDynamic, toDyn)
40 import Data.HashMap.Strict (HashMap)
41 import Data.List.Extra
42 import Data.Maybe
43 import Data.Typeable (TypeRep, typeOf)
44 import Development.Shake hiding (Normal)
45 import Development.Shake.Classes
46 import Development.Shake.FilePath
47 import System.Console.ANSI
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 -- | Add single quotes around a String.
102 quote :: String -> String
103 quote s = "'" ++ s ++ "'"
104
105 -- | Pretty-print a 'Bool' as a @"YES"@ or @"NO"@ string.
106 yesNo :: Bool -> String
107 yesNo True = "YES"
108 yesNo False = "NO"
109
110 -- | Normalise a path and convert all path separators to @/@, even on Windows.
111 unifyPath :: FilePath -> FilePath
112 unifyPath = toStandard . normaliseEx
113
114 -- | Combine paths with a forward slash regardless of platform.
115 (-/-) :: FilePath -> FilePath -> FilePath
116 "" -/- b = b
117 a -/- b
118 | last a == '/' = a ++ b
119 | otherwise = a ++ '/' : b
120
121 infixr 6 -/-
122
123 -- | Like Shake's '%>' but gives higher priority to longer patterns. Useful
124 -- in situations when a family of build rules, e.g. @"//*.a"@ and @"//*_p.a"@
125 -- can be matched by the same file, such as @library_p.a@. We break the tie
126 -- by preferring longer matches, which correpond to longer patterns.
127 (%%>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()
128 p %%> a = priority (fromIntegral (length p) + 1) $ p %> a
129
130 infix 1 %%>
131
132 -- | Insert a value into Shake's type-indexed map.
133 insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
134 insertExtra value = Map.insert (typeOf value) (toDyn value)
135
136 -- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the
137 -- setting is not found, return the provided default value instead.
138 userSetting :: Typeable a => a -> Action a
139 userSetting defaultValue = do
140 extra <- shakeExtra <$> getShakeOptions
141 let maybeValue = fromDynamic =<< Map.lookup (typeOf defaultValue) extra
142 return $ fromMaybe defaultValue maybeValue
143
144 newtype BuildRoot = BuildRoot FilePath deriving Typeable
145
146 -- | All build results are put into the 'buildRoot' directory.
147 buildRoot :: Action FilePath
148 buildRoot = do
149 BuildRoot path <- userSetting (BuildRoot "")
150 return path
151
152 -- | A version of 'fmap' with flipped arguments. Useful for manipulating values
153 -- in context, e.g. 'buildRoot', as in the example below.
154 --
155 -- @
156 -- buildRoot <&> (-/- "dir") == fmap (-/- "dir") buildRoot
157 -- @
158 (<&>) :: Functor f => f a -> (a -> b) -> f b
159 (<&>) = flip fmap
160
161 infixl 1 <&>
162
163 -- | Introduced in shake-0.16, so use to make the rest of the code compatible
164 type family RuleResult a
165
166 -- | Given a 'FilePath' to a source file, return 'True' if it is generated.
167 -- The current implementation simply assumes that a file is generated if it
168 -- lives in the 'buildRoot' directory. Since most files are not generated the
169 -- test is usually very fast.
170 isGeneratedSource :: FilePath -> Action Bool
171 isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
172
173 -- | Copy a file tracking the source. Create the target directory if missing.
174 copyFile :: FilePath -> FilePath -> Action ()
175 copyFile source target = do
176 need [source] -- Guarantee the source is built before printing progress info.
177 let dir = takeDirectory target
178 liftIO $ IO.createDirectoryIfMissing True dir
179 putProgressInfo =<< renderAction "Copy file" source target
180 copyFileChanged source target
181
182 -- | Copy a file without tracking the source. Create the target directory if missing.
183 copyFileUntracked :: FilePath -> FilePath -> Action ()
184 copyFileUntracked source target = do
185 let dir = takeDirectory target
186 liftIO $ IO.createDirectoryIfMissing True dir
187 putProgressInfo =<< renderAction "Copy file (untracked)" source target
188 liftIO $ IO.copyFile source target
189
190 -- | Transform a given file by applying a function to its contents.
191 fixFile :: FilePath -> (String -> String) -> Action ()
192 fixFile file f = do
193 putProgressInfo $ "| Fix " ++ file
194 contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do
195 old <- IO.hGetContents h
196 let new = f old
197 IO.evaluate $ rnf new
198 return new
199 liftIO $ writeFile file contents
200
201 -- | Make a given file executable by running the @chmod +x@ command.
202 makeExecutable :: FilePath -> Action ()
203 makeExecutable file = do
204 putProgressInfo $ "| Make " ++ quote file ++ " executable."
205 quietly $ cmd "chmod +x " [file]
206
207 -- | Move a file. Note that we cannot track the source, because it is moved.
208 moveFile :: FilePath -> FilePath -> Action ()
209 moveFile source target = do
210 putProgressInfo =<< renderAction "Move file" source target
211 quietly $ cmd ["mv", source, target]
212
213 -- | Remove a file that doesn't necessarily exist.
214 removeFile :: FilePath -> Action ()
215 removeFile file = do
216 putProgressInfo $ "| Remove file " ++ file
217 liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file
218
219 -- | Create a directory if it does not already exist.
220 createDirectory :: FilePath -> Action ()
221 createDirectory dir = do
222 putProgressInfo $ "| Create directory " ++ dir
223 liftIO $ IO.createDirectoryIfMissing True dir
224
225 -- | Copy a directory. The contents of the source directory is untracked.
226 copyDirectory :: FilePath -> FilePath -> Action ()
227 copyDirectory source target = do
228 putProgressInfo =<< renderAction "Copy directory" source target
229 quietly $ cmd ["cp", "-r", source, target]
230
231 -- | Move a directory. The contents of the source directory is untracked.
232 moveDirectory :: FilePath -> FilePath -> Action ()
233 moveDirectory source target = do
234 putProgressInfo =<< renderAction "Move directory" source target
235 quietly $ cmd ["mv", source, target]
236
237 -- | Remove a directory that doesn't necessarily exist.
238 removeDirectory :: FilePath -> Action ()
239 removeDirectory dir = do
240 putProgressInfo $ "| Remove directory " ++ dir
241 liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir
242
243 data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable)
244
245 -- | A more colourful version of Shake's 'putNormal'.
246 putColoured :: ColorIntensity -> Color -> String -> Action ()
247 putColoured intensity colour msg = do
248 useColour <- userSetting Never
249 supported <- liftIO $ hSupportsANSI IO.stdout
250 let c Never = False
251 c Auto = supported || IO.isWindows -- Colours do work on Windows
252 c Always = True
253 when (c useColour) . liftIO $ setSGR [SetColor Foreground intensity colour]
254 putNormal msg
255 when (c useColour) . liftIO $ setSGR [] >> IO.hFlush IO.stdout
256
257 newtype BuildProgressColour = BuildProgressColour (ColorIntensity, Color)
258 deriving Typeable
259
260 -- | Default 'BuildProgressColour'.
261 magenta :: BuildProgressColour
262 magenta = BuildProgressColour (Dull, Magenta)
263
264 -- | Print a build progress message (e.g. executing a build command).
265 putBuild :: String -> Action ()
266 putBuild msg = do
267 BuildProgressColour (intensity, colour) <- userSetting magenta
268 putColoured intensity colour msg
269
270 newtype SuccessColour = SuccessColour (ColorIntensity, Color)
271 deriving Typeable
272
273 -- | Default 'SuccessColour'.
274 green :: SuccessColour
275 green = SuccessColour (Dull, Green)
276
277 -- | Print a success message (e.g. a package is built successfully).
278 putSuccess :: String -> Action ()
279 putSuccess msg = do
280 SuccessColour (intensity, colour) <- userSetting green
281 putColoured intensity colour msg
282
283 data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable)
284
285 -- | Version of 'putBuild' controlled by @--progress-info@ command line argument.
286 putProgressInfo :: String -> Action ()
287 putProgressInfo msg = do
288 progressInfo <- userSetting None
289 when (progressInfo /= None) $ putBuild msg
290
291 -- | Render an action.
292 renderAction :: String -> FilePath -> FilePath -> Action String
293 renderAction what input output = do
294 progressInfo <- userSetting Normal
295 return $ case progressInfo of
296 None -> ""
297 Brief -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
298 Normal -> renderBox [ what, " input: " ++ i, " => output: " ++ o ]
299 Unicorn -> renderUnicorn [ what, " input: " ++ i, " => output: " ++ o ]
300 where
301 i = unifyPath input
302 o = unifyPath output
303
304 -- | Render the successful build of a program.
305 renderProgram :: String -> String -> String -> String
306 renderProgram name bin synopsis = renderBox [ "Successfully built program " ++ name
307 , "Executable: " ++ bin
308 , "Program synopsis: " ++ synopsis ++ "."]
309
310 -- | Render the successful build of a library.
311 renderLibrary :: String -> String -> String -> String
312 renderLibrary name lib synopsis = renderBox [ "Successfully built library " ++ name
313 , "Library: " ++ lib
314 , "Library synopsis: " ++ synopsis ++ "."]
315
316 -- | Render the given set of lines in an ASCII box. The minimum width and
317 -- whether to use Unicode symbols are hardcoded in the function's body.
318 --
319 -- >>> renderBox (words "lorem ipsum")
320 -- /----------\
321 -- | lorem |
322 -- | ipsum |
323 -- \----------/
324 renderBox :: [String] -> String
325 renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
326 where
327 -- Minimum total width of the box in characters
328 minimumBoxWidth = 32
329
330 -- TODO: Make this setting configurable? Setting to True by default seems
331 -- to work poorly with many fonts.
332 useUnicode = False
333
334 -- Characters to draw the box
335 (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
336 | useUnicode = ('', '', '', '', '', '', ' ')
337 | otherwise = ('-', '|', '/', '\\', '\\', '/', ' ')
338
339 -- Box width, taking minimum desired length and content into account.
340 -- The -4 is for the beginning and end pipe/padding symbols, as
341 -- in "| xxx |".
342 boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
343 where
344 maxContentLength = maximum (map length ls)
345
346 renderLine l = concat
347 [ [pipe, padding]
348 , padToLengthWith boxContentWidth padding l
349 , [padding, pipe] ]
350 where
351 padToLengthWith n filler x = x ++ replicate (n - length x) filler
352
353 (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
354 , botLeft : dashes ++ [botRight] )
355 where
356 -- +1 for each non-dash (= corner) char
357 dashes = replicate (boxContentWidth + 2) dash
358
359 -- | Render the given set of lines next to our favorite unicorn Robert.
360 renderUnicorn :: [String] -> String
361 renderUnicorn ls =
362 unlines $ take (max (length ponyLines) (length boxLines)) $
363 zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
364 where
365 ponyLines :: [String]
366 ponyLines = [ " ,;,,;'"
367 , " ,;;'( Robert the spitting unicorn"
368 , " __ ,;;' ' \\ wants you to know"
369 , " /' '\\'~~'~' \\ /'\\.) that a task "
370 , " ,;( ) / |. / just finished! "
371 , " ,;' \\ /-.,,( ) \\ "
372 , " ^ ) / ) / )| Almost there! "
373 , " || || \\) "
374 , " (_\\ (_\\ " ]
375 ponyPadding :: String
376 ponyPadding = " "
377 boxLines :: [String]
378 boxLines = ["", "", ""] ++ (lines . renderBox $ ls)