13483ceef397018d075311dc25bc3e46a60ebffc
[hadrian.git] / src / Base.hs
1 module Base (
2 module Control.Applicative,
3 module Control.Monad.Extra,
4 module Data.Char,
5 module Data.Function,
6 module Data.List,
7 module Data.Maybe,
8 module Data.Monoid,
9 module Development.Shake,
10 module Development.Shake.Classes,
11 module Development.Shake.Config,
12 module Development.Shake.FilePath,
13 module Development.Shake.Util,
14 module System.Console.ANSI,
15 shakeFilesPath, configPath, bootPackageConstraints, packageDependencies,
16 replaceEq, replaceSeparators, decodeModule,
17 unifyPath, (-/-), chunksOfSize,
18 putColoured, putOracle, putBuild, putSuccess, putError,
19 bimap, minusOrd, intersectOrd,
20 removeFileIfExists
21 ) where
22
23 import Control.Applicative
24 import Control.Monad.Extra
25 import Data.Char
26 import Data.Function
27 import Data.List
28 import Data.Maybe
29 import Data.Monoid
30 import Development.Shake hiding (unit, (*>))
31 import Development.Shake.Classes
32 import Development.Shake.Config
33 import Development.Shake.FilePath
34 import Development.Shake.Util
35 import System.Console.ANSI
36 import qualified System.Directory as IO
37 import System.IO
38
39 -- Build system files and paths
40 shakeFilesPath :: FilePath
41 shakeFilesPath = "_build/"
42
43 configPath :: FilePath
44 configPath = "shake/cfg/"
45
46 bootPackageConstraints :: FilePath
47 bootPackageConstraints = shakeFilesPath ++ "boot-package-constraints"
48
49 packageDependencies :: FilePath
50 packageDependencies = shakeFilesPath ++ "package-dependencies"
51
52 -- Utility functions
53 -- Find and replace all occurrences of a value in a list
54 replaceEq :: Eq a => a -> a -> [a] -> [a]
55 replaceEq from = replaceIf (== from)
56
57 -- Find and replace all occurrences of path separators in a String with a Char
58 replaceSeparators :: Char -> String -> String
59 replaceSeparators = replaceIf isPathSeparator
60
61 replaceIf :: (a -> Bool) -> a -> [a] -> [a]
62 replaceIf p to = map (\from -> if p from then to else from)
63
64 -- Given a module name extract the directory and file names, e.g.:
65 -- decodeModule "Data.Functor.Identity" = ("Data/Functor/", "Identity")
66 decodeModule :: String -> (FilePath, String)
67 decodeModule = splitFileName . replaceEq '.' '/'
68
69 -- Normalise a path and convert all path separators to /, even on Windows.
70 unifyPath :: FilePath -> FilePath
71 unifyPath = toStandard . normaliseEx
72
73 -- Combine paths using </> and apply unifyPath to the result
74 (-/-) :: FilePath -> FilePath -> FilePath
75 a -/- b = unifyPath $ a </> b
76
77 infixr 6 -/-
78
79 -- (chunksOfSize size strings) splits a given list of strings into chunks not
80 -- exceeding the given 'size'.
81 chunksOfSize :: Int -> [String] -> [[String]]
82 chunksOfSize _ [] = []
83 chunksOfSize size strings = reverse chunk : chunksOfSize size rest
84 where
85 (chunk, rest) = go [] 0 strings
86 go res _ [] = (res, [])
87 go res chunkSize (s:ss) =
88 if newSize > size then (res, s:ss) else go (s:res) newSize ss
89 where
90 newSize = chunkSize + length s
91
92 -- A more colourful version of Shake's putNormal
93 putColoured :: Color -> String -> Action ()
94 putColoured colour msg = do
95 liftIO $ setSGR [SetColor Foreground Vivid colour]
96 putNormal msg
97 liftIO $ setSGR []
98 liftIO $ hFlush stdout
99
100 -- Make oracle output more distinguishable
101 putOracle :: String -> Action ()
102 putOracle = putColoured Blue
103
104 -- Make build output more distinguishable
105 putBuild :: String -> Action ()
106 putBuild = putColoured White
107
108 -- A more colourful version of success message
109 putSuccess :: String -> Action ()
110 putSuccess = putColoured Green
111
112 -- A more colourful version of error message
113 putError :: String -> Action a
114 putError msg = do
115 putColoured Red msg
116 error $ "GHC build system error: " ++ msg
117
118 -- Depending on Data.Bifunctor only for this function seems an overkill
119 bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
120 bimap f g (x, y) = (f x, g y)
121
122 -- Depending on Data.List.Ordered only for these two functions seems an overkill
123 minusOrd :: Ord a => [a] -> [a] -> [a]
124 minusOrd [] _ = []
125 minusOrd xs [] = xs
126 minusOrd (x:xs) (y:ys) = case compare x y of
127 LT -> x : minusOrd xs (y:ys)
128 EQ -> minusOrd xs ys
129 GT -> minusOrd (x:xs) ys
130
131 intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
132 intersectOrd cmp = loop
133 where
134 loop [] _ = []
135 loop _ [] = []
136 loop (x:xs) (y:ys) = case cmp x y of
137 LT -> loop xs (y:ys)
138 EQ -> x : loop xs ys
139 GT -> loop (x:xs) ys
140
141 -- Convenient helper function for removing a file that doesn't necessarily exist
142 removeFileIfExists :: FilePath -> Action ()
143 removeFileIfExists f = liftIO . whenM (IO.doesFileExist f) $ IO.removeFile f