328eb984f767e114939ad05f4a59fdbfd697997a
[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 -- * Miscellaneous utilities
21 minusOrd, intersectOrd, lookupAll, replaceEq, quote, replaceSeparators,
22 unifyPath, (-/-), versionToInt, matchVersionedFilePath, putColoured
23 ) where
24
25 import Control.Applicative
26 import Control.Monad.Extra
27 import Control.Monad.Reader
28 import Data.Bifunctor
29 import Data.Char
30 import Data.Function
31 import Data.List.Extra
32 import Data.Maybe
33 import Data.Monoid
34 import Development.Shake hiding (parallel, unit, (*>), Normal)
35 import Development.Shake.Classes
36 import Development.Shake.FilePath
37 import System.Console.ANSI
38 import System.IO
39 import System.Info
40
41 -- TODO: reexport Stage, etc.?
42
43 -- Build system files and paths
44 hadrianPath :: FilePath
45 hadrianPath = "hadrian"
46
47 configPath :: FilePath
48 configPath = hadrianPath -/- "cfg"
49
50 configFile :: FilePath
51 configFile = configPath -/- "system.config"
52
53 -- | Path to source files of the build system, e.g. this file is located at
54 -- sourcePath -/- "Base.hs". We use this to `need` some of the source files.
55 sourcePath :: FilePath
56 sourcePath = hadrianPath -/- "src"
57
58 -- TODO: move to buildRootPath, see #113
59 programInplacePath :: FilePath
60 programInplacePath = "inplace/bin"
61
62 -- | Find and replace all occurrences of a value in a list.
63 replaceEq :: Eq a => a -> a -> [a] -> [a]
64 replaceEq from = replaceWhen (== from)
65
66 -- | Find and replace all occurrences of path separators in a String with a Char.
67 replaceSeparators :: Char -> String -> String
68 replaceSeparators = replaceWhen isPathSeparator
69
70 replaceWhen :: (a -> Bool) -> a -> [a] -> [a]
71 replaceWhen p to = map (\from -> if p from then to else from)
72
73 -- | Add quotes around a String.
74 quote :: String -> String
75 quote s = "\"" ++ s ++ "\""
76
77 -- | Given a version string such as "2.16.2" produce an integer equivalent.
78 versionToInt :: String -> Int
79 versionToInt s = major * 1000 + minor * 10 + patch
80 where
81 [major, minor, patch] = map read . words $ replaceEq '.' ' ' s
82
83 -- | Normalise a path and convert all path separators to @/@, even on Windows.
84 unifyPath :: FilePath -> FilePath
85 unifyPath = toStandard . normaliseEx
86
87 -- | Combine paths with a forward slash regardless of platform.
88 (-/-) :: FilePath -> FilePath -> FilePath
89 "" -/- b = b
90 a -/- b
91 | last a == '/' = a ++ b
92 | otherwise = a ++ '/' : b
93
94 infixr 6 -/-
95
96 -- Explicit definition to avoid dependency on Data.List.Ordered
97 -- | Difference of two ordered lists.
98 minusOrd :: Ord a => [a] -> [a] -> [a]
99 minusOrd [] _ = []
100 minusOrd xs [] = xs
101 minusOrd (x:xs) (y:ys) = case compare x y of
102 LT -> x : minusOrd xs (y:ys)
103 EQ -> minusOrd xs ys
104 GT -> minusOrd (x:xs) ys
105
106 -- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests
107 -- | Intersection of two ordered lists by a predicate.
108 intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
109 intersectOrd cmp = loop
110 where
111 loop [] _ = []
112 loop _ [] = []
113 loop (x:xs) (y:ys) = case cmp x y of
114 LT -> loop xs (y:ys)
115 EQ -> x : loop xs (y:ys)
116 GT -> loop (x:xs) ys
117
118 -- | Lookup all elements of a given sorted list in a given sorted dictionary.
119 -- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has
120 -- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|).
121 --
122 -- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3]
123 -- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list
124 lookupAll :: Ord a => [a] -> [(a, b)] -> [Maybe b]
125 lookupAll [] _ = []
126 lookupAll (_:xs) [] = Nothing : lookupAll xs []
127 lookupAll (x:xs) (y:ys) = case compare x (fst y) of
128 LT -> Nothing : lookupAll xs (y:ys)
129 EQ -> Just (snd y) : lookupAll xs (y:ys)
130 GT -> lookupAll (x:xs) ys
131
132 -- | Given a @prefix@ and a @suffix@ check whether a @filePath@ matches the
133 -- template @prefix ++ version ++ suffix@ where @version@ is an arbitrary string
134 -- comprising digits (@0-9@), dashes (@-@), and dots (@.@). Examples:
135 --
136 --- * @'matchVersionedFilePath' "foo/bar" ".a" "foo/bar.a" '==' 'True'@
137 --- * @'matchVersionedFilePath' "foo/bar" ".a" "foo\bar.a" '==' 'False'@
138 --- * @'matchVersionedFilePath' "foo/bar" "a" "foo/bar.a" '==' 'True'@
139 --- * @'matchVersionedFilePath' "foo/bar" "" "foo/bar.a" '==' 'False'@
140 --- * @'matchVersionedFilePath' "foo/bar" "a" "foo/bar-0.1.a" '==' 'True'@
141 --- * @'matchVersionedFilePath' "foo/bar-" "a" "foo/bar-0.1.a" '==' 'True'@
142 --- * @'matchVersionedFilePath' "foo/bar/" "a" "foo/bar-0.1.a" '==' 'False'@
143 matchVersionedFilePath :: String -> String -> FilePath -> Bool
144 matchVersionedFilePath prefix suffix filePath =
145 case stripPrefix prefix filePath >>= stripSuffix suffix of
146 Nothing -> False
147 Just version -> all (\c -> isDigit c || c == '-' || c == '.') version
148
149 -- | A more colourful version of Shake's putNormal.
150 putColoured :: ColorIntensity -> Color -> String -> Action ()
151 putColoured intensity colour msg = do
152 liftIO $ set [SetColor Foreground intensity colour]
153 putNormal msg
154 liftIO $ set []
155 liftIO $ hFlush stdout
156 where
157 set a = do
158 supported <- hSupportsANSI stdout
159 when (win || supported) $ setSGR a
160 -- An ugly hack to always try to print colours when on mingw and cygwin.
161 -- See: https://github.com/snowleopard/hadrian/pull/253
162 win = "mingw" `isPrefixOf` os || "cygwin" `isPrefixOf` os