Expression: Don't re-export Base
[hadrian.git] / src / Base.hs
1 module Base (
2 -- * General utilities
3 module Control.Applicative,
4 module Control.Monad.Extra,
5 module Control.Monad.Reader,
6 module Data.Function,
7 module Data.List,
8 module Data.Maybe,
9 module Data.Monoid,
10
11 -- * Shake
12 module Development.Shake,
13 module Development.Shake.Classes,
14 module Development.Shake.Config,
15 module Development.Shake.FilePath,
16 module Development.Shake.Util,
17
18 -- * Paths
19 shakeFilesPath, configPath, sourcePath, programInplacePath,
20 bootPackageConstraints, packageDependencies,
21 bootstrappingConf, bootstrappingConfInitialised,
22
23 -- * Output
24 putColoured, putOracle, putBuild, putSuccess, putError, renderBox,
25 module System.Console.ANSI,
26
27 -- * Miscellaneous utilities
28 bimap, minusOrd, intersectOrd, replaceEq, quote, chunksOfSize,
29 replaceSeparators, decodeModule, encodeModule, unifyPath, (-/-),
30 versionToInt, removeFileIfExists, removeDirectoryIfExists
31 ) where
32
33 import Control.Applicative
34 import Control.Monad.Extra
35 import Control.Monad.Reader
36 import Data.Function
37 import Data.List
38 import Data.Maybe
39 import Data.Monoid
40 import Development.Shake hiding (unit, (*>), parallel)
41 import Development.Shake.Classes
42 import Development.Shake.Config
43 import Development.Shake.FilePath
44 import Development.Shake.Util
45 import System.Console.ANSI
46 import qualified System.Directory as IO
47 import System.IO
48
49 -- Build system files and paths
50 shakePath :: FilePath
51 shakePath = "shake-build"
52
53 shakeFilesPath :: FilePath
54 shakeFilesPath = shakePath -/- ".db"
55
56 configPath :: FilePath
57 configPath = shakePath -/- "cfg"
58
59 -- | Path to source files of the build system, e.g. this file is located at
60 -- sourcePath -/- "Base.hs". We use this to `need` some of the source files.
61 sourcePath :: FilePath
62 sourcePath = shakePath -/- "src"
63
64 programInplacePath :: FilePath
65 programInplacePath = "inplace/bin"
66
67 bootPackageConstraints :: FilePath
68 bootPackageConstraints = shakeFilesPath -/- "boot-package-constraints"
69
70 packageDependencies :: FilePath
71 packageDependencies = shakeFilesPath -/- "package-dependencies"
72
73 bootstrappingConf :: FilePath
74 bootstrappingConf = "libraries/bootstrapping.conf"
75
76 bootstrappingConfInitialised :: FilePath
77 bootstrappingConfInitialised = shakeFilesPath -/- "bootstrapping-conf-initialised"
78
79 -- Utility functions
80 -- | Find and replace all occurrences of a value in a list
81 replaceEq :: Eq a => a -> a -> [a] -> [a]
82 replaceEq from = replaceIf (== from)
83
84 -- | Find and replace all occurrences of path separators in a String with a Char
85 replaceSeparators :: Char -> String -> String
86 replaceSeparators = replaceIf isPathSeparator
87
88 replaceIf :: (a -> Bool) -> a -> [a] -> [a]
89 replaceIf p to = map (\from -> if p from then to else from)
90
91 -- | Add quotes to a String
92 quote :: String -> String
93 quote s = "\"" ++ s ++ "\""
94
95 -- | Given a version string such as "2.16.2" produce an integer equivalent
96 versionToInt :: String -> Int
97 versionToInt s = major * 1000 + minor * 10 + patch
98 where
99 [major, minor, patch] = map read . words $ replaceEq '.' ' ' s
100
101 -- | Given a module name extract the directory and file name, e.g.:
102 --
103 -- > decodeModule "Data.Functor.Identity" = ("Data/Functor/", "Identity")
104 decodeModule :: String -> (FilePath, String)
105 decodeModule = splitFileName . replaceEq '.' '/'
106
107 -- | Given the directory and file name find the corresponding module name, e.g.:
108 --
109 -- > encodeModule "Data/Functor/" "Identity.hs" = "Data.Functor.Identity"
110 encodeModule :: FilePath -> String -> String
111 encodeModule dir file = replaceEq '/' '.' $ dir -/- takeBaseName file
112
113 -- | Normalise a path and convert all path separators to @/@, even on Windows.
114 unifyPath :: FilePath -> FilePath
115 unifyPath = toStandard . normaliseEx
116
117 -- | Combine paths using '</>' and apply 'unifyPath' to the result
118 (-/-) :: FilePath -> FilePath -> FilePath
119 a -/- b = unifyPath $ a </> b
120
121 infixr 6 -/-
122
123 -- | @chunksOfSize size strings@ splits a given list of strings into chunks not
124 -- exceeding the given @size@.
125 chunksOfSize :: Int -> [String] -> [[String]]
126 chunksOfSize _ [] = []
127 chunksOfSize size strings = reverse chunk : chunksOfSize size rest
128 where
129 (chunk, rest) = go [] 0 strings
130 go res _ [] = (res, [])
131 go res chunkSize (s:ss) =
132 if newSize > size then (res, s:ss) else go (s:res) newSize ss
133 where
134 newSize = chunkSize + length s
135
136 -- | A more colourful version of Shake's putNormal
137 putColoured :: Color -> String -> Action ()
138 putColoured colour msg = do
139 liftIO $ setSGR [SetColor Foreground Vivid colour]
140 putNormal msg
141 liftIO $ setSGR []
142 liftIO $ hFlush stdout
143
144 -- | Make oracle output more distinguishable
145 putOracle :: String -> Action ()
146 putOracle = putColoured Blue
147
148 -- | Make build output more distinguishable
149 putBuild :: String -> Action ()
150 putBuild = putColoured White
151
152 -- | A more colourful version of success message
153 putSuccess :: String -> Action ()
154 putSuccess = putColoured Green
155
156 -- | A more colourful version of error message
157 putError :: String -> Action a
158 putError msg = do
159 putColoured Red msg
160 error $ "GHC build system error: " ++ msg
161
162 -- | Render the given set of lines in a ASCII box
163 renderBox :: [String] -> String
164 renderBox ls =
165 unlines $ [begin] ++ map (bar++) ls ++ [end]
166 where
167 (begin,bar,end)
168 | useUnicode = ( "╭──────────"
169 , "│ "
170 , "╰──────────"
171 )
172 | otherwise = ( "/----------"
173 , "| "
174 , "\\----------"
175 )
176 -- FIXME: See Shake #364.
177 useUnicode = False
178
179 -- Depending on Data.Bifunctor only for this function seems an overkill
180 bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
181 bimap f g (x, y) = (f x, g y)
182
183 -- Depending on Data.List.Ordered only for these two functions seems an overkill
184 minusOrd :: Ord a => [a] -> [a] -> [a]
185 minusOrd [] _ = []
186 minusOrd xs [] = xs
187 minusOrd (x:xs) (y:ys) = case compare x y of
188 LT -> x : minusOrd xs (y:ys)
189 EQ -> minusOrd xs ys
190 GT -> minusOrd (x:xs) ys
191
192 intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
193 intersectOrd cmp = loop
194 where
195 loop [] _ = []
196 loop _ [] = []
197 loop (x:xs) (y:ys) = case cmp x y of
198 LT -> loop xs (y:ys)
199 EQ -> x : loop xs ys
200 GT -> loop (x:xs) ys
201
202 -- | Remove a file that doesn't necessarily exist
203 removeFileIfExists :: FilePath -> Action ()
204 removeFileIfExists f = liftIO . whenM (IO.doesFileExist f) $ IO.removeFile f
205
206 -- | Remove a directory that doesn't necessarily exist
207 removeDirectoryIfExists :: FilePath -> Action ()
208 removeDirectoryIfExists d =
209 liftIO . whenM (IO.doesDirectoryExist d) $ IO.removeDirectoryRecursive d