Add Base.hs with Shake imports and build paths.
[hadrian.git] / src / Util.hs
1 module Util (
2 module Data.Char,
3 module System.Console.ANSI,
4 replaceIf, replaceEq, replaceSeparators,
5 unifyPath, (-/-),
6 chunksOfSize,
7 putColoured, redError, redError_,
8 bimap, minusOrd, intersectOrd
9 ) where
10
11 import Base
12 import Data.Char
13 import Control.Monad
14 import System.IO
15 import System.Console.ANSI
16
17 replaceIf :: (a -> Bool) -> a -> [a] -> [a]
18 replaceIf p to = map (\from -> if p from then to else from)
19
20 replaceEq :: Eq a => a -> a -> [a] -> [a]
21 replaceEq from = replaceIf (== from)
22
23 replaceSeparators :: Char -> String -> String
24 replaceSeparators = replaceIf isPathSeparator
25
26 -- Normalise a path and convert all path separators to /, even on Windows.
27 unifyPath :: FilePath -> FilePath
28 unifyPath = toStandard . normaliseEx
29
30 -- Combine paths using </> and apply unifyPath to the result
31 (-/-) :: FilePath -> FilePath -> FilePath
32 a -/- b = unifyPath $ a </> b
33
34 infixr 6 -/-
35
36 -- (chunksOfSize size ss) splits a list of strings 'ss' into chunks not
37 -- exceeding the given 'size'.
38 chunksOfSize :: Int -> [String] -> [[String]]
39 chunksOfSize _ [] = []
40 chunksOfSize size ss = reverse chunk : chunksOfSize size rest
41 where
42 (chunk, rest) = go [] 0 ss
43 go chunk _ [] = (chunk, [])
44 go chunk chunkSize (s:ss) = let newSize = chunkSize + length s
45 (newChunk, rest) = go (s:chunk) newSize ss
46 in
47 if newSize > size
48 then (chunk , s:ss)
49 else (newChunk, rest)
50
51 -- A more colourful version of Shake's putNormal
52 putColoured :: Color -> String -> Action ()
53 putColoured colour msg = do
54 liftIO $ setSGR [SetColor Foreground Vivid colour]
55 putNormal msg
56 liftIO $ setSGR []
57 liftIO $ hFlush stdout
58
59 -- A more colourful version of error
60 redError :: String -> Action a
61 redError msg = do
62 putColoured Red msg
63 error $ "GHC build system error: " ++ msg
64
65 redError_ :: String -> Action ()
66 redError_ = void . redError
67
68 -- Depending on Data.Bifunctor only for this function seems an overkill
69 bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
70 bimap f g (x, y) = (f x, g y)
71
72 -- Depending on Data.List.Ordered only for these two functions seems an overkill
73 minusOrd :: Ord a => [a] -> [a] -> [a]
74 minusOrd [] _ = []
75 minusOrd xs [] = xs
76 minusOrd (x:xs) (y:ys) = case compare x y of
77 LT -> x : minusOrd xs (y:ys)
78 EQ -> minusOrd xs ys
79 GT -> minusOrd (x:xs) ys
80
81 intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
82 intersectOrd cmp = loop
83 where
84 loop [] _ = []
85 loop _ [] = []
86 loop (x:xs) (y:ys) = case cmp x y of
87 LT -> loop xs (y:ys)
88 EQ -> x : loop xs ys
89 GT -> loop (x:xs) ys