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