625dfd8241fb995976ffe934e014a7cf0f57a5b1
[ghc.git] / src / Base.hs
1 module Base (
2 -- * General utilities
3 module Control.Applicative,
4 module Control.Monad.Extra,
5 module Data.Bifunctor,
6 module Data.Function,
7 module Data.List.Extra,
8 module Data.Maybe,
9 module Data.Monoid,
10 MonadTrans(lift),
11
12 -- * Shake
13 module Development.Shake,
14 module Development.Shake.Classes,
15 module Development.Shake.FilePath,
16
17 -- * Paths
18 configPath, configFile, sourcePath, programInplacePath,
19
20 -- * Output
21 putColoured, putOracle, putBuild, putSuccess, putError,
22
23 -- * Miscellaneous utilities
24 minusOrd, intersectOrd, lookupAll, replaceEq, quote, replaceSeparators,
25 decodeModule, encodeModule, unifyPath, (-/-), versionToInt,
26 removeFileIfExists, removeDirectoryIfExists, matchVersionedFilePath
27 ) where
28
29 import Control.Applicative
30 import Control.Monad.Extra
31 import Control.Monad.Reader
32 import Data.Bifunctor
33 import Data.Char
34 import Data.Function
35 import Data.List.Extra
36 import Data.Maybe
37 import Data.Monoid
38 import Development.Shake hiding (parallel, unit, (*>), Normal)
39 import Development.Shake.Classes
40 import Development.Shake.FilePath
41 import System.Console.ANSI
42 import qualified System.Directory as IO
43 import System.IO
44
45 -- TODO: reexport Stage, etc.?
46
47 -- Build system files and paths
48 hadrianPath :: FilePath
49 hadrianPath = "hadrian"
50
51 configPath :: FilePath
52 configPath = hadrianPath -/- "cfg"
53
54 configFile :: FilePath
55 configFile = configPath -/- "system.config"
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 = hadrianPath -/- "src"
61
62 -- TODO: move to buildRootPath, see #113
63 programInplacePath :: FilePath
64 programInplacePath = "inplace/bin"
65
66 -- Utility functions
67 -- | Find and replace all occurrences of a value in a list
68 replaceEq :: Eq a => a -> a -> [a] -> [a]
69 replaceEq from = replaceWhen (== from)
70
71 -- | Find and replace all occurrences of path separators in a String with a Char
72 replaceSeparators :: Char -> String -> String
73 replaceSeparators = replaceWhen isPathSeparator
74
75 replaceWhen :: (a -> Bool) -> a -> [a] -> [a]
76 replaceWhen p to = map (\from -> if p from then to else from)
77
78 -- | Add quotes to a String
79 quote :: String -> String
80 quote s = "\"" ++ s ++ "\""
81
82 -- | Given a version string such as "2.16.2" produce an integer equivalent
83 versionToInt :: String -> Int
84 versionToInt s = major * 1000 + minor * 10 + patch
85 where
86 [major, minor, patch] = map read . words $ replaceEq '.' ' ' s
87
88 -- | Given a module name extract the directory and file name, e.g.:
89 --
90 -- > decodeModule "Data.Functor.Identity" == ("Data/Functor/", "Identity")
91 -- > decodeModule "Prelude" == ("./", "Prelude")
92 decodeModule :: String -> (FilePath, String)
93 decodeModule = splitFileName . replaceEq '.' '/'
94
95 -- | Given the directory and file name find the corresponding module name, e.g.:
96 --
97 -- > encodeModule "Data/Functor/" "Identity.hs" == "Data.Functor.Identity"
98 -- > encodeModule "./" "Prelude" == "Prelude"
99 -- > uncurry encodeModule (decodeModule name) == name
100 encodeModule :: FilePath -> String -> String
101 encodeModule dir file = replaceEq '/' '.' $ dir -/- takeBaseName file
102
103 -- | Normalise a path and convert all path separators to @/@, even on Windows.
104 unifyPath :: FilePath -> FilePath
105 unifyPath = toStandard . normaliseEx
106
107 -- | Combine paths using '</>' and apply 'unifyPath' to the result
108 (-/-) :: FilePath -> FilePath -> FilePath
109 a -/- b = unifyPath $ a </> b
110
111 infixr 6 -/-
112
113 -- | A more colourful version of Shake's putNormal
114 putColoured :: Color -> String -> Action ()
115 putColoured colour msg = do
116 liftIO $ setSGR [SetColor Foreground Vivid colour]
117 putNormal msg
118 liftIO $ setSGR []
119 liftIO $ hFlush stdout
120
121 -- | Make oracle output more distinguishable
122 putOracle :: String -> Action ()
123 putOracle = putColoured Blue
124
125 -- | Make build output more distinguishable
126 putBuild :: String -> Action ()
127 putBuild = putColoured White
128
129 -- | A more colourful version of success message
130 putSuccess :: String -> Action ()
131 putSuccess = putColoured Green
132
133 -- | A more colourful version of error message
134 putError :: String -> Action a
135 putError msg = do
136 putColoured Red msg
137 error $ "GHC build system error: " ++ msg
138
139 -- Explicit definition to avoid dependency on Data.List.Ordered
140 -- | Difference of two ordered lists.
141 minusOrd :: Ord a => [a] -> [a] -> [a]
142 minusOrd [] _ = []
143 minusOrd xs [] = xs
144 minusOrd (x:xs) (y:ys) = case compare x y of
145 LT -> x : minusOrd xs (y:ys)
146 EQ -> minusOrd xs ys
147 GT -> minusOrd (x:xs) ys
148
149 -- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests
150 -- | Intersection of two ordered lists by a predicate.
151 intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
152 intersectOrd cmp = loop
153 where
154 loop [] _ = []
155 loop _ [] = []
156 loop (x:xs) (y:ys) = case cmp x y of
157 LT -> loop xs (y:ys)
158 EQ -> x : loop xs (y:ys)
159 GT -> loop (x:xs) ys
160
161 -- | Lookup all elements of a given sorted list in a given sorted dictionary.
162 -- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has
163 -- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|).
164 --
165 -- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3]
166 -- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list
167 lookupAll :: Ord a => [a] -> [(a, b)] -> [Maybe b]
168 lookupAll [] _ = []
169 lookupAll (_:xs) [] = Nothing : lookupAll xs []
170 lookupAll (x:xs) (y:ys) = case compare x (fst y) of
171 LT -> Nothing : lookupAll xs (y:ys)
172 EQ -> Just (snd y) : lookupAll xs (y:ys)
173 GT -> lookupAll (x:xs) ys
174
175 -- | Remove a file that doesn't necessarily exist
176 removeFileIfExists :: FilePath -> Action ()
177 removeFileIfExists f = liftIO . whenM (IO.doesFileExist f) $ IO.removeFile f
178
179 -- | Remove a directory that doesn't necessarily exist
180 removeDirectoryIfExists :: FilePath -> Action ()
181 removeDirectoryIfExists d =
182 liftIO . whenM (IO.doesDirectoryExist d) $ IO.removeDirectoryRecursive d
183
184 -- | Given a @prefix@ and a @suffix@ check whether a @filePath@ matches the
185 -- template @prefix ++ version ++ suffix@ where @version@ is an arbitrary string
186 -- comprising digits (@0-9@), dashes (@-@), and dots (@.@). Examples:
187 --
188 --- * @'matchVersionedFilePath' "foo/bar" ".a" "foo/bar.a" '==' 'True'@
189 --- * @'matchVersionedFilePath' "foo/bar" ".a" "foo\bar.a" '==' 'False'@
190 --- * @'matchVersionedFilePath' "foo/bar" "a" "foo/bar.a" '==' 'True'@
191 --- * @'matchVersionedFilePath' "foo/bar" "" "foo/bar.a" '==' 'False'@
192 --- * @'matchVersionedFilePath' "foo/bar" "a" "foo/bar-0.1.a" '==' 'True'@
193 --- * @'matchVersionedFilePath' "foo/bar-" "a" "foo/bar-0.1.a" '==' 'True'@
194 --- * @'matchVersionedFilePath' "foo/bar/" "a" "foo/bar-0.1.a" '==' 'False'@
195 matchVersionedFilePath :: String -> String -> FilePath -> Bool
196 matchVersionedFilePath prefix suffix filePath =
197 case stripPrefix prefix filePath >>= stripSuffix suffix of
198 Nothing -> False
199 Just version -> all (\c -> isDigit c || c == '-' || c == '.') version