Util.hs 1.72 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,
Andrey Mokhov's avatar
Andrey Mokhov committed
7
    putColoured, redError, redError_
8
9
    ) where

10
import Base
11
import Data.Char
Andrey Mokhov's avatar
Andrey Mokhov committed
12
13
import System.Console.ANSI
import System.IO
Andrey Mokhov's avatar
Andrey Mokhov committed
14
import Control.Monad
15
16

replaceIf :: (a -> Bool) -> a -> [a] -> [a]
17
replaceIf p to = map (\from -> if p from then to else from)
18
19
20

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

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

25
26
27
unifyPath :: FilePath -> FilePath
unifyPath = toStandard . normaliseEx

28
29
30
31
32
33
34
35
36
37
38
39
40
41
-- (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
42

43
-- A more colourful version of Shake's putNormal
Andrey Mokhov's avatar
Andrey Mokhov committed
44
45
46
putColoured :: Color -> String -> Action ()
putColoured colour msg = do
    liftIO $ setSGR [SetColor Foreground Vivid colour]
Andrey Mokhov's avatar
Andrey Mokhov committed
47
48
49
    putNormal msg
    liftIO $ setSGR []
    liftIO $ hFlush stdout
50
51
52
53

-- A more colourful version of error
redError :: String -> Action a
redError msg = do
Andrey Mokhov's avatar
Andrey Mokhov committed
54
55
56
57
58
    putColoured Red msg
    error $ "GHC build system error: " ++ msg

redError_ :: String -> Action ()
redError_ = void . redError