Use Extra library
[hadrian.git] / src / Base.hs
1 module Base (
2 -- * General utilities
3 module Control.Applicative,
4 module Control.Monad.Extra,
5 module Data.Function,
6 module Data.List,
7 module Data.Maybe,
8 module Data.Monoid,
9 MonadTrans(lift),
10
11 -- * Shake
12 module Development.Shake,
13 module Development.Shake.Classes,
14 module Development.Shake.FilePath,
15
16 -- * Paths
17 shakeFilesPath, configPath, sourcePath, programInplacePath,
18 bootPackageConstraints, packageDependencies,
19 packageConfiguration, packageConfigurationInitialised,
20
21 -- * Output
22 putColoured, putOracle, putBuild, putSuccess, putError, renderBox,
23
24 -- * Miscellaneous utilities
25 bimap, minusOrd, intersectOrd, replaceEq, quote, chunksOfSize,
26 replaceSeparators, decodeModule, encodeModule, unifyPath, (-/-),
27 versionToInt, removeFileIfExists, removeDirectoryIfExists
28 ) where
29
30 import Control.Applicative
31 import Control.Monad.Extra
32 import Control.Monad.Reader
33 import Data.Function
34 import Data.List
35 import Data.Maybe
36 import Data.Monoid
37 import Development.Shake hiding (unit, (*>))
38 import Development.Shake.Classes
39 import Development.Shake.FilePath
40 import System.Console.ANSI
41 import qualified System.Directory as IO
42 import System.IO
43
44 -- TODO: reexport Stage, etc.?
45 import Stage
46
47 -- Build system files and paths
48 shakePath :: FilePath
49 shakePath = "shake-build"
50
51 shakeFilesPath :: FilePath
52 shakeFilesPath = shakePath -/- ".db"
53
54 configPath :: FilePath
55 configPath = shakePath -/- "cfg"
56
57 -- | Path to source files of the build system, e.g. this file is located at
58 -- sourcePath -/- "Base.hs". We use this to `need` some of the source files.
59 sourcePath :: FilePath
60 sourcePath = shakePath -/- "src"
61
62 programInplacePath :: FilePath
63 programInplacePath = "inplace/bin"
64
65 bootPackageConstraints :: FilePath
66 bootPackageConstraints = shakeFilesPath -/- "boot-package-constraints"
67
68 packageDependencies :: FilePath
69 packageDependencies = shakeFilesPath -/- "package-dependencies"
70
71 packageConfiguration :: Stage -> FilePath
72 packageConfiguration Stage0 = "libraries/bootstrapping.conf"
73 packageConfiguration _ = "inplace/lib/package.conf.d"
74
75 -- StageN, N > 0, share the same packageConfiguration (see above)
76 packageConfigurationInitialised :: Stage -> FilePath
77 packageConfigurationInitialised stage =
78 shakeFilesPath -/- "package-configuration-initialised-"
79 ++ stageString (min stage Stage1)
80
81 -- Utility functions
82 -- | Find and replace all occurrences of a value in a list
83 replaceEq :: Eq a => a -> a -> [a] -> [a]
84 replaceEq from = replaceWhen (== from)
85
86 -- | Find and replace all occurrences of path separators in a String with a Char
87 replaceSeparators :: Char -> String -> String
88 replaceSeparators = replaceWhen isPathSeparator
89
90 replaceWhen :: (a -> Bool) -> a -> [a] -> [a]
91 replaceWhen p to = map (\from -> if p from then to else from)
92
93 -- | @chunksOfSize size strings@ splits a given list of strings into chunks not
94 -- exceeding the given @size@.
95 chunksOfSize :: Int -> [String] -> [[String]]
96 chunksOfSize _ [] = []
97 chunksOfSize size strings = reverse chunk : chunksOfSize size rest
98 where
99 (chunk, rest) = go [] 0 strings
100 go res _ [] = (res, [])
101 go res chunkSize (s:ss) =
102 if newSize > size then (res, s:ss) else go (s:res) newSize ss
103 where
104 newSize = chunkSize + length s
105
106 -- | Add quotes to a String
107 quote :: String -> String
108 quote s = "\"" ++ s ++ "\""
109
110 -- | Given a version string such as "2.16.2" produce an integer equivalent
111 versionToInt :: String -> Int
112 versionToInt s = major * 1000 + minor * 10 + patch
113 where
114 [major, minor, patch] = map read . words $ replaceEq '.' ' ' s
115
116 -- | Given a module name extract the directory and file name, e.g.:
117 --
118 -- > decodeModule "Data.Functor.Identity" = ("Data/Functor/", "Identity")
119 decodeModule :: String -> (FilePath, String)
120 decodeModule = splitFileName . replaceEq '.' '/'
121
122 -- | Given the directory and file name find the corresponding module name, e.g.:
123 --
124 -- > encodeModule "Data/Functor/" "Identity.hs" = "Data.Functor.Identity"
125 encodeModule :: FilePath -> String -> String
126 encodeModule dir file = replaceEq '/' '.' $ dir -/- takeBaseName file
127
128 -- | Normalise a path and convert all path separators to @/@, even on Windows.
129 unifyPath :: FilePath -> FilePath
130 unifyPath = toStandard . normaliseEx
131
132 -- | Combine paths using '</>' and apply 'unifyPath' to the result
133 (-/-) :: FilePath -> FilePath -> FilePath
134 a -/- b = unifyPath $ a </> b
135
136 infixr 6 -/-
137
138 -- | A more colourful version of Shake's putNormal
139 putColoured :: Color -> String -> Action ()
140 putColoured colour msg = do
141 liftIO $ setSGR [SetColor Foreground Vivid colour]
142 putNormal msg
143 liftIO $ setSGR []
144 liftIO $ hFlush stdout
145
146 -- | Make oracle output more distinguishable
147 putOracle :: String -> Action ()
148 putOracle = putColoured Blue
149
150 -- | Make build output more distinguishable
151 putBuild :: String -> Action ()
152 putBuild = putColoured White
153
154 -- | A more colourful version of success message
155 putSuccess :: String -> Action ()
156 putSuccess = putColoured Green
157
158 -- | A more colourful version of error message
159 putError :: String -> Action a
160 putError msg = do
161 putColoured Red msg
162 error $ "GHC build system error: " ++ msg
163
164 -- | Render the given set of lines in a nice box of ASCII.
165 --
166 -- The minimum width and whether to use Unicode symbols are hardcoded in the
167 -- function's body.
168 --
169 -- >>> renderBox (words "lorem ipsum")
170 -- /----------\
171 -- | lorem |
172 -- | ipsum |
173 -- \----------/
174 renderBox :: [String] -> String
175 renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
176 where
177 -- Minimum total width of the box in characters
178 minimumBoxWidth = 32
179
180 -- FIXME: See Shake #364.
181 useUnicode = False
182
183 -- Characters to draw the box
184 (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
185 | useUnicode = ('', '', '', '', '', '', ' ')
186 | otherwise = ('-', '|', '/', '\\', '\\', '/', ' ')
187
188 -- Box width, taking minimum desired length and content into account.
189 -- The -4 is for the beginning and end pipe/padding symbols, as
190 -- in "| xxx |".
191 boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
192 where
193 maxContentLength = maximum (map length ls)
194
195 renderLine l = concat
196 [ [pipe, padding]
197 , padToLengthWith boxContentWidth padding l
198 , [padding, pipe] ]
199 where
200 padToLengthWith n filler x = x ++ replicate (n - length x) filler
201
202 (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
203 , botLeft : dashes ++ [botRight] )
204 where
205 -- +1 for each non-dash (= corner) char
206 dashes = replicate (boxContentWidth + 2) dash
207
208 -- Explicit definition to avoid dependency on Data.Bifunctor
209 -- | Bifunctor bimap.
210 bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
211 bimap f g (x, y) = (f x, g y)
212
213 -- Explicit definition to avoid dependency on Data.List.Ordered
214 -- | Difference of two ordered lists.
215 minusOrd :: Ord a => [a] -> [a] -> [a]
216 minusOrd [] _ = []
217 minusOrd xs [] = xs
218 minusOrd (x:xs) (y:ys) = case compare x y of
219 LT -> x : minusOrd xs (y:ys)
220 EQ -> minusOrd xs ys
221 GT -> minusOrd (x:xs) ys
222
223 -- Explicit definition to avoid dependency on Data.List.Ordered
224 -- | Intersection of two ordered lists by a predicate.
225 intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
226 intersectOrd cmp = loop
227 where
228 loop [] _ = []
229 loop _ [] = []
230 loop (x:xs) (y:ys) = case cmp x y of
231 LT -> loop xs (y:ys)
232 EQ -> x : loop xs ys
233 GT -> loop (x:xs) ys
234
235 -- | Remove a file that doesn't necessarily exist
236 removeFileIfExists :: FilePath -> Action ()
237 removeFileIfExists f = liftIO . whenM (IO.doesFileExist f) $ IO.removeFile f
238
239 -- | Remove a directory that doesn't necessarily exist
240 removeDirectoryIfExists :: FilePath -> Action ()
241 removeDirectoryIfExists d =
242 liftIO . whenM (IO.doesDirectoryExist d) $ IO.removeDirectoryRecursive d