Clean up code, add comments.
[hadrian.git] / src / Base.hs
1 module Base (
2 module Control.Applicative,
3 module Control.Monad.Extra,
4 module Control.Monad.Reader,
5 module Data.Char,
6 module Data.Function,
7 module Data.List,
8 module Data.Maybe,
9 module Data.Monoid,
10 module Development.Shake,
11 module Development.Shake.Classes,
12 module Development.Shake.Config,
13 module Development.Shake.FilePath,
14 module Development.Shake.Util,
15 module System.Console.ANSI,
16 shakeFilesPath, configPath, bootPackageConstraints, packageDependencies,
17 replaceEq, replaceSeparators, decodeModule,
18 unifyPath, (-/-), chunksOfSize,
19 putColoured, putOracle, putBuild, putSuccess, putError,
20 bimap, minusOrd, intersectOrd,
21 removeFileIfExists
22 ) where
23
24 import Control.Applicative
25 import Control.Monad.Extra
26 import Control.Monad.Reader
27 import Data.Char
28 import Data.Function
29 import Data.List
30 import Data.Maybe
31 import Data.Monoid
32 import Development.Shake hiding (unit, (*>))
33 import Development.Shake.Classes
34 import Development.Shake.Config
35 import Development.Shake.FilePath
36 import Development.Shake.Util
37 import System.Console.ANSI
38 import qualified System.Directory as IO
39 import System.IO
40
41 -- Build system files and paths
42 shakeFilesPath :: FilePath
43 shakeFilesPath = "_build/"
44
45 configPath :: FilePath
46 configPath = "shake/cfg/"
47
48 bootPackageConstraints :: FilePath
49 bootPackageConstraints = shakeFilesPath ++ "boot-package-constraints"
50
51 packageDependencies :: FilePath
52 packageDependencies = shakeFilesPath ++ "package-dependencies"
53
54 -- Utility functions
55 -- Find and replace all occurrences of a value in a list
56 replaceEq :: Eq a => a -> a -> [a] -> [a]
57 replaceEq from = replaceIf (== from)
58
59 -- Find and replace all occurrences of path separators in a String with a Char
60 replaceSeparators :: Char -> String -> String
61 replaceSeparators = replaceIf isPathSeparator
62
63 replaceIf :: (a -> Bool) -> a -> [a] -> [a]
64 replaceIf p to = map (\from -> if p from then to else from)
65
66 -- Given a module name extract the directory and file names, e.g.:
67 -- decodeModule "Data.Functor.Identity" = ("Data/Functor/", "Identity")
68 decodeModule :: String -> (FilePath, String)
69 decodeModule = splitFileName . replaceEq '.' '/'
70
71 -- Normalise a path and convert all path separators to /, even on Windows.
72 unifyPath :: FilePath -> FilePath
73 unifyPath = toStandard . normaliseEx
74
75 -- Combine paths using </> and apply unifyPath to the result
76 (-/-) :: FilePath -> FilePath -> FilePath
77 a -/- b = unifyPath $ a </> b
78
79 infixr 6 -/-
80
81 -- (chunksOfSize size strings) splits a given list of strings into chunks not
82 -- exceeding the given 'size'.
83 chunksOfSize :: Int -> [String] -> [[String]]
84 chunksOfSize _ [] = []
85 chunksOfSize size strings = reverse chunk : chunksOfSize size rest
86 where
87 (chunk, rest) = go [] 0 strings
88 go res _ [] = (res, [])
89 go res chunkSize (s:ss) =
90 if newSize > size then (res, s:ss) else go (s:res) newSize ss
91 where
92 newSize = chunkSize + length s
93
94 -- A more colourful version of Shake's putNormal
95 putColoured :: Color -> String -> Action ()
96 putColoured colour msg = do
97 liftIO $ setSGR [SetColor Foreground Vivid colour]
98 putNormal msg
99 liftIO $ setSGR []
100 liftIO $ hFlush stdout
101
102 -- Make oracle output more distinguishable
103 putOracle :: String -> Action ()
104 putOracle = putColoured Blue
105
106 -- Make build output more distinguishable
107 putBuild :: String -> Action ()
108 putBuild = putColoured White
109
110 -- A more colourful version of success message
111 putSuccess :: String -> Action ()
112 putSuccess = putColoured Green
113
114 -- A more colourful version of error message
115 putError :: String -> Action a
116 putError msg = do
117 putColoured Red msg
118 error $ "GHC build system error: " ++ msg
119
120 -- Depending on Data.Bifunctor only for this function seems an overkill
121 bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
122 bimap f g (x, y) = (f x, g y)
123
124 -- Depending on Data.List.Ordered only for these two functions seems an overkill
125 minusOrd :: Ord a => [a] -> [a] -> [a]
126 minusOrd [] _ = []
127 minusOrd xs [] = xs
128 minusOrd (x:xs) (y:ys) = case compare x y of
129 LT -> x : minusOrd xs (y:ys)
130 EQ -> minusOrd xs ys
131 GT -> minusOrd (x:xs) ys
132
133 intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
134 intersectOrd cmp = loop
135 where
136 loop [] _ = []
137 loop _ [] = []
138 loop (x:xs) (y:ys) = case cmp x y of
139 LT -> loop xs (y:ys)
140 EQ -> x : loop xs ys
141 GT -> loop (x:xs) ys
142
143 -- Convenient helper function for removing a file that doesn't necessarily exist
144 removeFileIfExists :: FilePath -> Action ()
145 removeFileIfExists f = liftIO . whenM (IO.doesFileExist f) $ IO.removeFile f