Base.hs 5.38 KB
Newer Older
1
module Base (
Ben Gamari's avatar
Ben Gamari committed
2
    -- * General utilities
Andrey Mokhov's avatar
Andrey Mokhov committed
3 4
    module Control.Applicative,
    module Control.Monad.Extra,
5
    module Data.Bifunctor,
Andrey Mokhov's avatar
Andrey Mokhov committed
6
    module Data.Function,
7
    module Data.List.Extra,
Andrey Mokhov's avatar
Andrey Mokhov committed
8
    module Data.Maybe,
Andrey Mokhov's avatar
Andrey Mokhov committed
9
    module Data.Semigroup,
Ben Gamari's avatar
Ben Gamari committed
10 11

    -- * Shake
12 13
    module Development.Shake,
    module Development.Shake.Classes,
Andrey Mokhov's avatar
Andrey Mokhov committed
14
    module Development.Shake.FilePath,
Ben Gamari's avatar
Ben Gamari committed
15 16

    -- * Paths
17
    configPath, configFile, sourcePath,
Ben Gamari's avatar
Ben Gamari committed
18 19

    -- * Miscellaneous utilities
Andrey Mokhov's avatar
Andrey Mokhov committed
20
    minusOrd, intersectOrd, lookupAll, replaceEq, replaceSeparators, unifyPath,
Zhen Zhang's avatar
Zhen Zhang committed
21
    quote, (-/-), matchVersionedFilePath, matchGhcVersionedFilePath, putColoured
22 23
    ) where

Andrey Mokhov's avatar
Andrey Mokhov committed
24 25
import Control.Applicative
import Control.Monad.Extra
Andrey Mokhov's avatar
Andrey Mokhov committed
26
import Control.Monad.Reader
27
import Data.Bifunctor
28
import Data.Char
Andrey Mokhov's avatar
Andrey Mokhov committed
29
import Data.Function
30
import Data.List.Extra
Andrey Mokhov's avatar
Andrey Mokhov committed
31
import Data.Maybe
Andrey Mokhov's avatar
Andrey Mokhov committed
32
import Data.Semigroup
Andrey Mokhov's avatar
Andrey Mokhov committed
33
import Development.Shake hiding (parallel, unit, (*>), Normal)
34 35
import Development.Shake.Classes
import Development.Shake.FilePath
36
import Hadrian.Utilities
Andrey Mokhov's avatar
Andrey Mokhov committed
37 38
import System.Console.ANSI
import System.IO
39
import System.Info
40

41 42
import CmdLineFlag

43 44
-- TODO: reexport Stage, etc.?

Andrey Mokhov's avatar
Andrey Mokhov committed
45
-- | Hadrian lives in 'hadrianPath' directory of the GHC tree.
Andrey Mokhov's avatar
Andrey Mokhov committed
46 47
hadrianPath :: FilePath
hadrianPath = "hadrian"
48

Andrey Mokhov's avatar
Andrey Mokhov committed
49
-- TODO: Move this to build directory?
50
configPath :: FilePath
Andrey Mokhov's avatar
Andrey Mokhov committed
51
configPath = hadrianPath -/- "cfg"
52

53 54 55
configFile :: FilePath
configFile = configPath -/- "system.config"

56 57 58
-- | Path to source files of the build system, e.g. this file is located at
-- sourcePath -/- "Base.hs". We use this to `need` some of the source files.
sourcePath :: FilePath
Andrey Mokhov's avatar
Andrey Mokhov committed
59
sourcePath = hadrianPath -/- "src"
60

61
-- | Find and replace all occurrences of a value in a list.
Andrey Mokhov's avatar
Andrey Mokhov committed
62
replaceEq :: Eq a => a -> a -> [a] -> [a]
63
replaceEq from = replaceWhen (== from)
Andrey Mokhov's avatar
Andrey Mokhov committed
64

65
-- | Find and replace all occurrences of path separators in a String with a Char.
Andrey Mokhov's avatar
Andrey Mokhov committed
66
replaceSeparators :: Char -> String -> String
67
replaceSeparators = replaceWhen isPathSeparator
Andrey Mokhov's avatar
Andrey Mokhov committed
68

69 70
replaceWhen :: (a -> Bool) -> a -> [a] -> [a]
replaceWhen p to = map (\from -> if p from then to else from)
Andrey Mokhov's avatar
Andrey Mokhov committed
71

Andrey Mokhov's avatar
Andrey Mokhov committed
72 73 74 75
-- | Add single quotes around a String.
quote :: String -> String
quote s = "'" ++ s ++ "'"

quchen's avatar
quchen committed
76 77
-- Explicit definition to avoid dependency on Data.List.Ordered
-- | Difference of two ordered lists.
Andrey Mokhov's avatar
Andrey Mokhov committed
78 79 80 81 82 83 84 85
minusOrd :: Ord a => [a] -> [a] -> [a]
minusOrd [] _  = []
minusOrd xs [] = xs
minusOrd (x:xs) (y:ys) = case compare x y of
    LT -> x : minusOrd xs (y:ys)
    EQ ->     minusOrd xs ys
    GT ->     minusOrd (x:xs) ys

86
-- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests
quchen's avatar
quchen committed
87
-- | Intersection of two ordered lists by a predicate.
Andrey Mokhov's avatar
Andrey Mokhov committed
88 89 90 91 92 93
intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
intersectOrd cmp = loop
  where
    loop [] _ = []
    loop _ [] = []
    loop (x:xs) (y:ys) = case cmp x y of
Andrey Mokhov's avatar
Andrey Mokhov committed
94
        LT ->     loop xs (y:ys)
95
        EQ -> x : loop xs (y:ys)
Andrey Mokhov's avatar
Andrey Mokhov committed
96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
        GT ->     loop (x:xs) ys

-- | Lookup all elements of a given sorted list in a given sorted dictionary.
-- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has
-- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|).
--
-- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3]
-- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list
lookupAll :: Ord a => [a] -> [(a, b)] -> [Maybe b]
lookupAll []     _      = []
lookupAll (_:xs) []     = Nothing : lookupAll xs []
lookupAll (x:xs) (y:ys) = case compare x (fst y) of
    LT -> Nothing      : lookupAll xs (y:ys)
    EQ -> Just (snd y) : lookupAll xs (y:ys)
    GT -> lookupAll (x:xs) ys
Andrey Mokhov's avatar
Andrey Mokhov committed
111

112 113 114 115 116
-- | Given a @prefix@ and a @suffix@ check whether a @filePath@ matches the
-- template @prefix ++ version ++ suffix@ where @version@ is an arbitrary string
-- comprising digits (@0-9@), dashes (@-@), and dots (@.@). Examples:
--
--- * @'matchVersionedFilePath' "foo/bar"  ".a" "foo/bar.a"     '==' 'True'@
117
--- * @'matchVersionedFilePath' "foo/bar"  ".a" "foo\bar.a"     '==' 'False'@
118 119 120 121 122 123 124
--- * @'matchVersionedFilePath' "foo/bar"  "a"  "foo/bar.a"     '==' 'True'@
--- * @'matchVersionedFilePath' "foo/bar"  ""   "foo/bar.a"     '==' 'False'@
--- * @'matchVersionedFilePath' "foo/bar"  "a"  "foo/bar-0.1.a" '==' 'True'@
--- * @'matchVersionedFilePath' "foo/bar-" "a"  "foo/bar-0.1.a" '==' 'True'@
--- * @'matchVersionedFilePath' "foo/bar/" "a"  "foo/bar-0.1.a" '==' 'False'@
matchVersionedFilePath :: String -> String -> FilePath -> Bool
matchVersionedFilePath prefix suffix filePath =
125
    case stripPrefix prefix filePath >>= stripSuffix suffix of
126 127
        Nothing      -> False
        Just version -> all (\c -> isDigit c || c == '-' || c == '.') version
128

Zhen Zhang's avatar
Zhen Zhang committed
129 130 131 132 133 134
matchGhcVersionedFilePath :: String -> String -> FilePath -> Bool
matchGhcVersionedFilePath prefix ext filePath =
    case stripPrefix prefix filePath >>= stripSuffix ext of
        Nothing -> False
        Just _  -> True

135 136 137
-- | A more colourful version of Shake's putNormal.
putColoured :: ColorIntensity -> Color -> String -> Action ()
putColoured intensity colour msg = do
138 139
    c <- useColour
    when c . liftIO $ setSGR [SetColor Foreground intensity colour]
140
    putNormal msg
141 142 143 144 145 146 147 148 149 150 151 152 153
    when c . liftIO $ do
        setSGR []
        hFlush stdout

useColour :: Action Bool
useColour = case cmdProgressColour of
    Never  -> return False
    Always -> return True
    Auto   -> do
        supported <- liftIO $ hSupportsANSI stdout
        -- An ugly hack to always try to print colours when on mingw and cygwin.
        let windows = any (`isPrefixOf` os) ["mingw", "cygwin"]
        return $ windows || supported