Util.hs 3.58 KB
Newer Older
1
module Util (
Andrey Mokhov's avatar
Andrey Mokhov committed
2
    module Control.Applicative,
Andrey Mokhov's avatar
Andrey Mokhov committed
3
    module Control.Monad.Extra,
4
    module Data.Char,
Andrey Mokhov's avatar
Andrey Mokhov committed
5
6
7
8
    module Data.Function,
    module Data.List,
    module Data.Maybe,
    module Data.Monoid,
Andrey Mokhov's avatar
Andrey Mokhov committed
9
    module System.Console.ANSI,
Andrey Mokhov's avatar
Andrey Mokhov committed
10
11
    replaceEq, replaceSeparators, decodeModule,
    unifyPath, (-/-), chunksOfSize,
12
    putColoured, putOracle, putBuild, putSuccess, putError,
Andrey Mokhov's avatar
Andrey Mokhov committed
13
    bimap, minusOrd, intersectOrd,
Andrey Mokhov's avatar
Andrey Mokhov committed
14
    removeFileIfExists
15
16
    ) where

Andrey Mokhov's avatar
Andrey Mokhov committed
17
import Base hiding (doesFileExist)
Andrey Mokhov's avatar
Andrey Mokhov committed
18
import Control.Applicative
Andrey Mokhov's avatar
Andrey Mokhov committed
19
import Control.Monad.Extra
20
import Data.Char
Andrey Mokhov's avatar
Andrey Mokhov committed
21
22
23
24
import Data.Function
import Data.List
import Data.Maybe
import Data.Monoid
25
import System.Console.ANSI
Andrey Mokhov's avatar
Andrey Mokhov committed
26
27
import System.Directory (doesFileExist, removeFile)
import System.IO
28
29

replaceIf :: (a -> Bool) -> a -> [a] -> [a]
30
replaceIf p to = map (\from -> if p from then to else from)
31
32
33

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

35
replaceSeparators :: Char -> String -> String
36
37
replaceSeparators = replaceIf isPathSeparator

Andrey Mokhov's avatar
Andrey Mokhov committed
38
39
40
41
42
-- 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 '.' '/'

43
-- Normalise a path and convert all path separators to /, even on Windows.
44
45
46
unifyPath :: FilePath -> FilePath
unifyPath = toStandard . normaliseEx

47
48
49
50
-- Combine paths using </> and apply unifyPath to the result
(-/-) :: FilePath -> FilePath -> FilePath
a -/- b = unifyPath $ a </> b

51
infixr 6 -/-
52

Andrey Mokhov's avatar
Andrey Mokhov committed
53
-- (chunksOfSize size strings) splits a given list of strings into chunks not
54
55
56
-- exceeding the given 'size'.
chunksOfSize :: Int -> [String] -> [[String]]
chunksOfSize _    [] = []
Andrey Mokhov's avatar
Andrey Mokhov committed
57
chunksOfSize size strings = reverse chunk : chunksOfSize size rest
58
  where
Andrey Mokhov's avatar
Andrey Mokhov committed
59
60
61
    (chunk, rest) = go [] 0 strings
    go res _         []     = (res, [])
    go res chunkSize (s:ss) =
62
        if newSize > size then (res, s:ss) else go (s:res) newSize ss
Andrey Mokhov's avatar
Andrey Mokhov committed
63
64
      where
        newSize = chunkSize + length s
Andrey Mokhov's avatar
Andrey Mokhov committed
65

66
-- A more colourful version of Shake's putNormal
Andrey Mokhov's avatar
Andrey Mokhov committed
67
68
69
putColoured :: Color -> String -> Action ()
putColoured colour msg = do
    liftIO $ setSGR [SetColor Foreground Vivid colour]
Andrey Mokhov's avatar
Andrey Mokhov committed
70
71
72
    putNormal msg
    liftIO $ setSGR []
    liftIO $ hFlush stdout
73

74
75
76
77
78
79
80
81
-- Make oracle output more distinguishable
putOracle :: String -> Action ()
putOracle = putColoured Blue

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

Andrey Mokhov's avatar
Andrey Mokhov committed
82
-- A more colourful version of success message
83
84
putSuccess :: String -> Action ()
putSuccess = putColoured Green
85

Andrey Mokhov's avatar
Andrey Mokhov committed
86
-- A more colourful version of error message
87
88
putError :: String -> Action a
putError msg = do
Andrey Mokhov's avatar
Andrey Mokhov committed
89
90
91
    putColoured Red msg
    error $ "GHC build system error: " ++ msg

92
93
94
-- 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)
95

96
-- Depending on Data.List.Ordered only for these two functions seems an overkill
97
98
99
100
101
102
103
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
104
105
106
107
108
109
110
111
112
113

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
114

Andrey Mokhov's avatar
Andrey Mokhov committed
115
116
117
-- Convenient helper function for removing a file that doesn't necessarily exist
removeFileIfExists :: FilePath -> Action ()
removeFileIfExists file = liftIO . whenM (doesFileExist file) $ removeFile file