925c42712067fd9439b986e0478aa27b0d120cd9
[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, replace, quote, chunksOfSize,
26 replaceSeparators, decodeModule, encodeModule, unifyPath, (-/-),
27 versionToInt, removeFileIfExists, removeDirectoryIfExists, wordsWhen
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 -- | Find all occurrences of substring 'from' and replace them to 'to' in a
94 -- given string. Not very efficient, but simple and fast enough for our purposes
95 replace :: Eq a => [a] -> [a] -> [a] -> [a]
96 replace from to = go
97 where
98 skipFrom = drop $ length from
99 go [] = []
100 go s @ (x : xs)
101 | from `isPrefixOf` s = to ++ go (skipFrom s)
102 | otherwise = x : go xs
103
104 -- | Split a list into chunks in places where the predicate @p@ holds.
105 -- See: http://stackoverflow.com/a/4981265
106 wordsWhen :: Eq a => (a -> Bool) -> [a] -> [[a]]
107 wordsWhen p list =
108 case dropWhile p list of
109 [] -> []
110 l -> w : wordsWhen p rest where (w, rest) = break p l
111
112 -- | @chunksOfSize size strings@ splits a given list of strings into chunks not
113 -- exceeding the given @size@.
114 chunksOfSize :: Int -> [String] -> [[String]]
115 chunksOfSize _ [] = []
116 chunksOfSize size strings = reverse chunk : chunksOfSize size rest
117 where
118 (chunk, rest) = go [] 0 strings
119 go res _ [] = (res, [])
120 go res chunkSize (s:ss) =
121 if newSize > size then (res, s:ss) else go (s:res) newSize ss
122 where
123 newSize = chunkSize + length s
124
125 -- | Add quotes to a String
126 quote :: String -> String
127 quote s = "\"" ++ s ++ "\""
128
129 -- | Given a version string such as "2.16.2" produce an integer equivalent
130 versionToInt :: String -> Int
131 versionToInt s = major * 1000 + minor * 10 + patch
132 where
133 [major, minor, patch] = map read . words $ replaceEq '.' ' ' s
134
135 -- | Given a module name extract the directory and file name, e.g.:
136 --
137 -- > decodeModule "Data.Functor.Identity" = ("Data/Functor/", "Identity")
138 decodeModule :: String -> (FilePath, String)
139 decodeModule = splitFileName . replaceEq '.' '/'
140
141 -- | Given the directory and file name find the corresponding module name, e.g.:
142 --
143 -- > encodeModule "Data/Functor/" "Identity.hs" = "Data.Functor.Identity"
144 encodeModule :: FilePath -> String -> String
145 encodeModule dir file = replaceEq '/' '.' $ dir -/- takeBaseName file
146
147 -- | Normalise a path and convert all path separators to @/@, even on Windows.
148 unifyPath :: FilePath -> FilePath
149 unifyPath = toStandard . normaliseEx
150
151 -- | Combine paths using '</>' and apply 'unifyPath' to the result
152 (-/-) :: FilePath -> FilePath -> FilePath
153 a -/- b = unifyPath $ a </> b
154
155 infixr 6 -/-
156
157 -- | A more colourful version of Shake's putNormal
158 putColoured :: Color -> String -> Action ()
159 putColoured colour msg = do
160 liftIO $ setSGR [SetColor Foreground Vivid colour]
161 putNormal msg
162 liftIO $ setSGR []
163 liftIO $ hFlush stdout
164
165 -- | Make oracle output more distinguishable
166 putOracle :: String -> Action ()
167 putOracle = putColoured Blue
168
169 -- | Make build output more distinguishable
170 putBuild :: String -> Action ()
171 putBuild = putColoured White
172
173 -- | A more colourful version of success message
174 putSuccess :: String -> Action ()
175 putSuccess = putColoured Green
176
177 -- | A more colourful version of error message
178 putError :: String -> Action a
179 putError msg = do
180 putColoured Red msg
181 error $ "GHC build system error: " ++ msg
182
183 -- | Render the given set of lines in a nice box of ASCII.
184 --
185 -- The minimum width and whether to use Unicode symbols are hardcoded in the
186 -- function's body.
187 --
188 -- >>> renderBox (words "lorem ipsum")
189 -- /----------\
190 -- | lorem |
191 -- | ipsum |
192 -- \----------/
193 renderBox :: [String] -> String
194 renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
195 where
196 -- Minimum total width of the box in characters
197 minimumBoxWidth = 32
198
199 -- FIXME: See Shake #364.
200 useUnicode = False
201
202 -- Characters to draw the box
203 (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
204 | useUnicode = ('', '', '', '', '', '', ' ')
205 | otherwise = ('-', '|', '/', '\\', '\\', '/', ' ')
206
207 -- Box width, taking minimum desired length and content into account.
208 -- The -4 is for the beginning and end pipe/padding symbols, as
209 -- in "| xxx |".
210 boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
211 where
212 maxContentLength = maximum (map length ls)
213
214 renderLine l = concat
215 [ [pipe, padding]
216 , padToLengthWith boxContentWidth padding l
217 , [padding, pipe] ]
218 where
219 padToLengthWith n filler x = x ++ replicate (n - length x) filler
220
221 (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
222 , botLeft : dashes ++ [botRight] )
223 where
224 -- +1 for each non-dash (= corner) char
225 dashes = replicate (boxContentWidth + 2) dash
226
227 -- Explicit definition to avoid dependency on Data.Bifunctor
228 -- | Bifunctor bimap.
229 bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
230 bimap f g (x, y) = (f x, g y)
231
232 -- Explicit definition to avoid dependency on Data.List.Ordered
233 -- | Difference of two ordered lists.
234 minusOrd :: Ord a => [a] -> [a] -> [a]
235 minusOrd [] _ = []
236 minusOrd xs [] = xs
237 minusOrd (x:xs) (y:ys) = case compare x y of
238 LT -> x : minusOrd xs (y:ys)
239 EQ -> minusOrd xs ys
240 GT -> minusOrd (x:xs) ys
241
242 -- Explicit definition to avoid dependency on Data.List.Ordered
243 -- | Intersection of two ordered lists by a predicate.
244 intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
245 intersectOrd cmp = loop
246 where
247 loop [] _ = []
248 loop _ [] = []
249 loop (x:xs) (y:ys) = case cmp x y of
250 LT -> loop xs (y:ys)
251 EQ -> x : loop xs ys
252 GT -> loop (x:xs) ys
253
254 -- | Remove a file that doesn't necessarily exist
255 removeFileIfExists :: FilePath -> Action ()
256 removeFileIfExists f = liftIO . whenM (IO.doesFileExist f) $ IO.removeFile f
257
258 -- | Remove a directory that doesn't necessarily exist
259 removeDirectoryIfExists :: FilePath -> Action ()
260 removeDirectoryIfExists d =
261 liftIO . whenM (IO.doesDirectoryExist d) $ IO.removeDirectoryRecursive d