Move versionToInt to Settings/Builders/Haddock
[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, (-/-), 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 -- | Normalise a path and convert all path separators to @/@, even on Windows.
78 unifyPath :: FilePath -> FilePath
79 unifyPath = toStandard . normaliseEx
80
81 -- | Combine paths with a forward slash regardless of platform.
82 (-/-) :: FilePath -> FilePath -> FilePath
83 "" -/- b = b
84 a -/- b
85 | last a == '/' = a ++ b
86 | otherwise = a ++ '/' : b
87
88 infixr 6 -/-
89
90 -- Explicit definition to avoid dependency on Data.List.Ordered
91 -- | Difference of two ordered lists.
92 minusOrd :: Ord a => [a] -> [a] -> [a]
93 minusOrd [] _ = []
94 minusOrd xs [] = xs
95 minusOrd (x:xs) (y:ys) = case compare x y of
96 LT -> x : minusOrd xs (y:ys)
97 EQ -> minusOrd xs ys
98 GT -> minusOrd (x:xs) ys
99
100 -- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests
101 -- | Intersection of two ordered lists by a predicate.
102 intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
103 intersectOrd cmp = loop
104 where
105 loop [] _ = []
106 loop _ [] = []
107 loop (x:xs) (y:ys) = case cmp x y of
108 LT -> loop xs (y:ys)
109 EQ -> x : loop xs (y:ys)
110 GT -> loop (x:xs) ys
111
112 -- | Lookup all elements of a given sorted list in a given sorted dictionary.
113 -- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has
114 -- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|).
115 --
116 -- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3]
117 -- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list
118 lookupAll :: Ord a => [a] -> [(a, b)] -> [Maybe b]
119 lookupAll [] _ = []
120 lookupAll (_:xs) [] = Nothing : lookupAll xs []
121 lookupAll (x:xs) (y:ys) = case compare x (fst y) of
122 LT -> Nothing : lookupAll xs (y:ys)
123 EQ -> Just (snd y) : lookupAll xs (y:ys)
124 GT -> lookupAll (x:xs) ys
125
126 -- | Given a @prefix@ and a @suffix@ check whether a @filePath@ matches the
127 -- template @prefix ++ version ++ suffix@ where @version@ is an arbitrary string
128 -- comprising digits (@0-9@), dashes (@-@), and dots (@.@). Examples:
129 --
130 --- * @'matchVersionedFilePath' "foo/bar" ".a" "foo/bar.a" '==' 'True'@
131 --- * @'matchVersionedFilePath' "foo/bar" ".a" "foo\bar.a" '==' 'False'@
132 --- * @'matchVersionedFilePath' "foo/bar" "a" "foo/bar.a" '==' 'True'@
133 --- * @'matchVersionedFilePath' "foo/bar" "" "foo/bar.a" '==' 'False'@
134 --- * @'matchVersionedFilePath' "foo/bar" "a" "foo/bar-0.1.a" '==' 'True'@
135 --- * @'matchVersionedFilePath' "foo/bar-" "a" "foo/bar-0.1.a" '==' 'True'@
136 --- * @'matchVersionedFilePath' "foo/bar/" "a" "foo/bar-0.1.a" '==' 'False'@
137 matchVersionedFilePath :: String -> String -> FilePath -> Bool
138 matchVersionedFilePath prefix suffix filePath =
139 case stripPrefix prefix filePath >>= stripSuffix suffix of
140 Nothing -> False
141 Just version -> all (\c -> isDigit c || c == '-' || c == '.') version
142
143 -- | A more colourful version of Shake's putNormal.
144 putColoured :: ColorIntensity -> Color -> String -> Action ()
145 putColoured intensity colour msg = do
146 liftIO $ set [SetColor Foreground intensity colour]
147 putNormal msg
148 liftIO $ set []
149 liftIO $ hFlush stdout
150 where
151 set a = do
152 supported <- hSupportsANSI stdout
153 when (win || supported) $ setSGR a
154 -- An ugly hack to always try to print colours when on mingw and cygwin.
155 -- See: https://github.com/snowleopard/hadrian/pull/253
156 win = "mingw" `isPrefixOf` os || "cygwin" `isPrefixOf` os