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

12
import Base
13
import Data.Char
Andrey Mokhov's avatar
Andrey Mokhov committed
14
import Control.Monad
15
16
import System.IO
import System.Console.ANSI
Andrey Mokhov's avatar
Andrey Mokhov committed
17
import qualified System.Directory as IO
18
19

replaceIf :: (a -> Bool) -> a -> [a] -> [a]
20
replaceIf p to = map (\from -> if p from then to else from)
21
22
23

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

25
replaceSeparators :: Char -> String -> String
26
27
replaceSeparators = replaceIf isPathSeparator

Andrey Mokhov's avatar
Andrey Mokhov committed
28
29
30
31
32
-- Given a module name extract the directory and file names, e.g.:
-- decodeModule "Data.Functor.Identity" = ("Data/Functor/", "Identity")
decodeModule :: String -> (FilePath, String)
decodeModule = splitFileName . replaceEq '.' '/'

33
-- Normalise a path and convert all path separators to /, even on Windows.
34
35
36
unifyPath :: FilePath -> FilePath
unifyPath = toStandard . normaliseEx

37
38
39
40
-- Combine paths using </> and apply unifyPath to the result
(-/-) :: FilePath -> FilePath -> FilePath
a -/- b = unifyPath $ a </> b

41
infixr 6 -/-
42

Andrey Mokhov's avatar
Andrey Mokhov committed
43
-- (chunksOfSize size strings) splits a given list of strings into chunks not
44
45
46
-- exceeding the given 'size'.
chunksOfSize :: Int -> [String] -> [[String]]
chunksOfSize _    [] = []
Andrey Mokhov's avatar
Andrey Mokhov committed
47
chunksOfSize size strings = reverse chunk : chunksOfSize size rest
48
  where
Andrey Mokhov's avatar
Andrey Mokhov committed
49
50
51
52
53
54
    (chunk, rest) = go [] 0 strings
    go res _         []     = (res, [])
    go res chunkSize (s:ss) =
        if newSize > size then (chunk, s:ss) else go (s:res) newSize ss
      where
        newSize = chunkSize + length s
Andrey Mokhov's avatar
Andrey Mokhov committed
55

56
-- A more colourful version of Shake's putNormal
Andrey Mokhov's avatar
Andrey Mokhov committed
57
58
59
putColoured :: Color -> String -> Action ()
putColoured colour msg = do
    liftIO $ setSGR [SetColor Foreground Vivid colour]
Andrey Mokhov's avatar
Andrey Mokhov committed
60
61
62
    putNormal msg
    liftIO $ setSGR []
    liftIO $ hFlush stdout
63

64
65
66
67
68
69
70
71
-- Make oracle output more distinguishable
putOracle :: String -> Action ()
putOracle = putColoured Blue

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

72
-- A more colourful version of error
73
74
putSuccess :: String -> Action ()
putSuccess = putColoured Green
75

76
-- A more colourful version of error
77
78
putError :: String -> Action a
putError msg = do
Andrey Mokhov's avatar
Andrey Mokhov committed
79
80
81
    putColoured Red msg
    error $ "GHC build system error: " ++ msg

82
83
84
-- 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)
85

86
-- Depending on Data.List.Ordered only for these two functions seems an overkill
87
88
89
90
91
92
93
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
94
95
96
97
98
99
100
101
102
103

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
Andrey Mokhov's avatar
Andrey Mokhov committed
104
105
106
107
108
109
110

-- Convenient helper function for removing a single file that doesn't
-- necessarily exist.
removeFile :: FilePath -> Action ()
removeFile file = do
    exists <- liftIO $ IO.doesFileExist file
    when exists . liftIO $ IO.removeFile file