Util.hs 2.91 KB
Newer Older
1
2
module Util (
    module Data.Char,
Andrey Mokhov's avatar
Andrey Mokhov committed
3
    module System.Console.ANSI,
4
    replaceIf, replaceEq, replaceSeparators,
5
    unifyPath, (-/-),
Andrey Mokhov's avatar
Andrey Mokhov committed
6
    chunksOfSize,
7
    putColoured, putOracle, putBuild, redError, redError_,
8
    bimap, minusOrd, intersectOrd
9
10
    ) where

11
import Base
12
import Data.Char
Andrey Mokhov's avatar
Andrey Mokhov committed
13
import Control.Monad
14
15
import System.IO
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
21

replaceEq :: Eq a => a -> a -> [a] -> [a]
replaceEq from = replaceIf (== from)
22

23
replaceSeparators :: Char -> String -> String
24
25
replaceSeparators = replaceIf isPathSeparator

26
-- Normalise a path and convert all path separators to /, even on Windows.
27
28
29
unifyPath :: FilePath -> FilePath
unifyPath = toStandard . normaliseEx

30
31
32
33
-- Combine paths using </> and apply unifyPath to the result
(-/-) :: FilePath -> FilePath -> FilePath
a -/- b = unifyPath $ a </> b

34
infixr 6 -/-
35

36
37
38
39
40
41
42
43
44
45
46
47
48
49
-- (chunksOfSize size ss) splits a list of strings 'ss' into chunks not
-- exceeding the given 'size'.
chunksOfSize :: Int -> [String] -> [[String]]
chunksOfSize _    [] = []
chunksOfSize size ss = reverse chunk : chunksOfSize size rest
  where
    (chunk, rest) = go [] 0 ss
    go chunk _         []     = (chunk, [])
    go chunk chunkSize (s:ss) = let newSize = chunkSize + length s
                                    (newChunk, rest) = go (s:chunk) newSize ss
                                in
                                if newSize > size
                                then (chunk   , s:ss)
                                else (newChunk, rest)
Andrey Mokhov's avatar
Andrey Mokhov committed
50

51
-- A more colourful version of Shake's putNormal
Andrey Mokhov's avatar
Andrey Mokhov committed
52
53
54
putColoured :: Color -> String -> Action ()
putColoured colour msg = do
    liftIO $ setSGR [SetColor Foreground Vivid colour]
Andrey Mokhov's avatar
Andrey Mokhov committed
55
56
57
    putNormal msg
    liftIO $ setSGR []
    liftIO $ hFlush stdout
58

59
60
61
62
63
64
65
66
-- Make oracle output more distinguishable
putOracle :: String -> Action ()
putOracle = putColoured Blue

-- Make build output more distinguishable
putBuild :: String -> Action ()
putBuild = putColoured White

67
68
69
-- A more colourful version of error
redError :: String -> Action a
redError msg = do
Andrey Mokhov's avatar
Andrey Mokhov committed
70
71
72
73
74
    putColoured Red msg
    error $ "GHC build system error: " ++ msg

redError_ :: String -> Action ()
redError_ = void . redError
75
76
77
78

-- Depending on Data.Bifunctor only for this function seems an overkill
bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
bimap f g (x, y) = (f x, g y)
79

80
-- Depending on Data.List.Ordered only for these two functions seems an overkill
81
82
83
84
85
86
87
minusOrd :: Ord a => [a] -> [a] -> [a]
minusOrd [] _  = []
minusOrd xs [] = xs
minusOrd (x:xs) (y:ys) = case compare x y of
    LT -> x : minusOrd xs (y:ys)
    EQ ->     minusOrd xs ys
    GT ->     minusOrd (x:xs) ys
88
89
90
91
92
93
94
95
96
97

intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
intersectOrd cmp = loop
  where
    loop [] _ = []
    loop _ [] = []
    loop (x:xs) (y:ys) = case cmp x y of
         LT ->     loop xs (y:ys)
         EQ -> x : loop xs ys
         GT ->     loop (x:xs) ys