Utilities.hs 14.2 KB
Newer Older
1
{-# LANGUAGE TypeFamilies #-}
2
module Hadrian.Utilities (
3 4 5
    -- * List manipulation
    fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll,

6
    -- * String manipulation
7
    quote, yesNo,
8

9
    -- * FilePath manipulation
10
    unifyPath, (-/-),
11

12 13 14
    -- * Accessing Shake's type-indexed map
    insertExtra, userSetting,

15 16 17
    -- * Paths
    BuildRoot (..), buildRoot, isGeneratedSource,

18 19 20 21
    -- * File system operations
    copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile,
    createDirectory, copyDirectory, moveDirectory, removeDirectory,

22 23 24 25
    -- * Diagnostic info
    UseColour (..), putColoured, BuildProgressColour (..), putBuild,
    SuccessColour (..), putSuccess, ProgressInfo (..),
    putProgressInfo, renderAction, renderProgram, renderLibrary, renderBox,
26 27
    renderUnicorn,

28 29 30
    -- * Shake compatibility
    RuleResult,

31
    -- * Miscellaneous
32
    (<&>), (%%>),
33

34 35
    -- * Useful re-exports
    Dynamic, fromDynamic, toDyn, TypeRep, typeOf
36 37
    ) where

38
import Control.Monad.Extra
39
import Data.Char
40
import Data.Dynamic (Dynamic, fromDynamic, toDyn)
41
import Data.HashMap.Strict (HashMap)
Andrey Mokhov's avatar
Andrey Mokhov committed
42
import Data.List.Extra
43
import Data.Maybe
44
import Data.Typeable (TypeRep, typeOf)
45
import Development.Shake hiding (Normal)
46
import Development.Shake.Classes
47
import Development.Shake.FilePath
48
import System.Console.ANSI
49

50 51 52 53 54
import qualified Control.Exception.Base as IO
import qualified Data.HashMap.Strict    as Map
import qualified System.Directory.Extra as IO
import qualified System.Info.Extra      as IO
import qualified System.IO              as IO
55

56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101
-- | Extract a value from a singleton list, or terminate with an error message
-- if the list does not contain exactly one value.
fromSingleton :: String -> [a] -> a
fromSingleton _   [res] = res
fromSingleton msg _     = error msg

-- | Find and replace all occurrences of a value in a list.
replaceEq :: Eq a => a -> a -> [a] -> [a]
replaceEq from to = map (\cur -> if cur == from then to else cur)

-- Explicit definition to avoid dependency on Data.List.Ordered
-- | Difference of two ordered lists.
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

-- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests
-- | Intersection of two ordered lists by a predicate.
intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
intersectOrd cmp = loop
  where
    loop [] _ = []
    loop _ [] = []
    loop (x:xs) (y:ys) = case cmp x y of
        LT ->     loop xs (y:ys)
        EQ -> x : loop xs (y:ys)
        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

102 103 104 105
-- | Add single quotes around a String.
quote :: String -> String
quote s = "'" ++ s ++ "'"

106 107 108 109 110
-- | Pretty-print a 'Bool' as a @"YES"@ or @"NO"@ string.
yesNo :: Bool -> String
yesNo True  = "YES"
yesNo False = "NO"

111 112 113 114 115 116 117 118 119 120 121 122
-- | Normalise a path and convert all path separators to @/@, even on Windows.
unifyPath :: FilePath -> FilePath
unifyPath = toStandard . normaliseEx

-- | Combine paths with a forward slash regardless of platform.
(-/-) :: FilePath -> FilePath -> FilePath
"" -/- b = b
a  -/- b
    | last a == '/' = a ++       b
    | otherwise     = a ++ '/' : b

infixr 6 -/-
Andrey Mokhov's avatar
Andrey Mokhov committed
123

124 125 126 127 128 129 130 131 132
-- | Like Shake's '%>' but gives higher priority to longer patterns. Useful
-- in situations when a family of build rules, e.g. @"//*.a"@ and @"//*_p.a"@
-- can be matched by the same file, such as @library_p.a@. We break the tie
-- by preferring longer matches, which correpond to longer patterns.
(%%>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()
p %%> a = priority (fromIntegral (length p) + 1) $ p %> a

infix 1 %%>

133 134 135 136 137 138 139 140 141 142 143 144
-- | Insert a value into Shake's type-indexed map.
insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
insertExtra value = Map.insert (typeOf value) (toDyn value)

-- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the
-- setting is not found, return the provided default value instead.
userSetting :: Typeable a => a -> Action a
userSetting defaultValue = do
    extra <- shakeExtra <$> getShakeOptions
    let maybeValue = fromDynamic =<< Map.lookup (typeOf defaultValue) extra
    return $ fromMaybe defaultValue maybeValue

145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
newtype BuildRoot = BuildRoot FilePath deriving Typeable

-- | All build results are put into the 'buildRoot' directory.
buildRoot :: Action FilePath
buildRoot = do
    BuildRoot path <- userSetting (BuildRoot "")
    return path

-- | A version of 'fmap' with flipped arguments. Useful for manipulating values
-- in context, e.g. 'buildRoot', as in the example below.
--
-- @
-- buildRoot <&> (-/- "dir") == fmap (-/- "dir") buildRoot
-- @
(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip fmap

infixl 1 <&>

164 165 166
-- | Introduced in shake-0.16, so use to make the rest of the code compatible
type family RuleResult a

167 168 169 170 171 172 173
-- | Given a 'FilePath' to a source file, return 'True' if it is generated.
-- The current implementation simply assumes that a file is generated if it
-- lives in the 'buildRoot' directory. Since most files are not generated the
-- test is usually very fast.
isGeneratedSource :: FilePath -> Action Bool
isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)

174 175 176 177 178 179 180
-- | Copy a file tracking the source. Create the target directory if missing.
copyFile :: FilePath -> FilePath -> Action ()
copyFile source target = do
    need [source] -- Guarantee the source is built before printing progress info.
    let dir = takeDirectory target
    liftIO $ IO.createDirectoryIfMissing True dir
    putProgressInfo =<< renderAction "Copy file" source target
Andrey Mokhov's avatar
Andrey Mokhov committed
181
    quietly $ copyFileChanged source target
182 183 184 185 186 187 188 189 190 191 192 193

-- | Copy a file without tracking the source. Create the target directory if missing.
copyFileUntracked :: FilePath -> FilePath -> Action ()
copyFileUntracked source target = do
    let dir = takeDirectory target
    liftIO $ IO.createDirectoryIfMissing True dir
    putProgressInfo =<< renderAction "Copy file (untracked)" source target
    liftIO $ IO.copyFile source target

-- | Transform a given file by applying a function to its contents.
fixFile :: FilePath -> (String -> String) -> Action ()
fixFile file f = do
194
    putProgressInfo $ "| Fix " ++ file
195 196 197 198 199 200 201 202 203 204
    contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do
        old <- IO.hGetContents h
        let new = f old
        IO.evaluate $ rnf new
        return new
    liftIO $ writeFile file contents

-- | Make a given file executable by running the @chmod +x@ command.
makeExecutable :: FilePath -> Action ()
makeExecutable file = do
205
    putProgressInfo $ "| Make " ++ quote file ++ " executable."
206 207 208 209 210 211 212 213 214 215 216
    quietly $ cmd "chmod +x " [file]

-- | Move a file. Note that we cannot track the source, because it is moved.
moveFile :: FilePath -> FilePath -> Action ()
moveFile source target = do
    putProgressInfo =<< renderAction "Move file" source target
    quietly $ cmd ["mv", source, target]

-- | Remove a file that doesn't necessarily exist.
removeFile :: FilePath -> Action ()
removeFile file = do
217
    putProgressInfo $ "| Remove file " ++ file
218 219 220 221 222
    liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file

-- | Create a directory if it does not already exist.
createDirectory :: FilePath -> Action ()
createDirectory dir = do
223
    putProgressInfo $ "| Create directory " ++ dir
224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240
    liftIO $ IO.createDirectoryIfMissing True dir

-- | Copy a directory. The contents of the source directory is untracked.
copyDirectory :: FilePath -> FilePath -> Action ()
copyDirectory source target = do
    putProgressInfo =<< renderAction "Copy directory" source target
    quietly $ cmd ["cp", "-r", source, target]

-- | Move a directory. The contents of the source directory is untracked.
moveDirectory :: FilePath -> FilePath -> Action ()
moveDirectory source target = do
    putProgressInfo =<< renderAction "Move directory" source target
    quietly $ cmd ["mv", source, target]

-- | Remove a directory that doesn't necessarily exist.
removeDirectory :: FilePath -> Action ()
removeDirectory dir = do
241
    putProgressInfo $ "| Remove directory " ++ dir
242 243
    liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir

244
data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable)
245 246

-- | A more colourful version of Shake's 'putNormal'.
247 248 249
putColoured :: ColorIntensity -> Color -> String -> Action ()
putColoured intensity colour msg = do
    useColour <- userSetting Never
250
    supported <- liftIO $ hSupportsANSI IO.stdout
251
    let c Never  = False
252
        c Auto   = supported || IO.isWindows -- Colours do work on Windows
253 254 255
        c Always = True
    when (c useColour) . liftIO $ setSGR [SetColor Foreground intensity colour]
    putNormal msg
256
    when (c useColour) . liftIO $ setSGR [] >> IO.hFlush IO.stdout
257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285

newtype BuildProgressColour = BuildProgressColour (ColorIntensity, Color)
    deriving Typeable

-- | Default 'BuildProgressColour'.
magenta :: BuildProgressColour
magenta = BuildProgressColour (Dull, Magenta)

-- | Print a build progress message (e.g. executing a build command).
putBuild :: String -> Action ()
putBuild msg = do
    BuildProgressColour (intensity, colour) <- userSetting magenta
    putColoured intensity colour msg

newtype SuccessColour = SuccessColour (ColorIntensity, Color)
    deriving Typeable

-- | Default 'SuccessColour'.
green :: SuccessColour
green = SuccessColour (Dull, Green)

-- | Print a success message (e.g. a package is built successfully).
putSuccess :: String -> Action ()
putSuccess msg = do
    SuccessColour (intensity, colour) <- userSetting green
    putColoured intensity colour msg

data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable)

286
-- | Version of 'putBuild' controlled by @--progress-info@ command line argument.
287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305
putProgressInfo :: String -> Action ()
putProgressInfo msg = do
    progressInfo <- userSetting None
    when (progressInfo /= None) $ putBuild msg

-- | Render an action.
renderAction :: String -> FilePath -> FilePath -> Action String
renderAction what input output = do
    progressInfo <- userSetting Normal
    return $ case progressInfo of
        None    -> ""
        Brief   -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
        Normal  -> renderBox [ what, "     input: " ++ i, " => output: " ++ o ]
        Unicorn -> renderUnicorn [ what, "     input: " ++ i, " => output: " ++ o ]
  where
    i = unifyPath input
    o = unifyPath output

-- | Render the successful build of a program.
306 307 308 309 310
renderProgram :: String -> String -> Maybe String -> String
renderProgram name bin synopsis = renderBox $
    [ "Successfully built program " ++ name
    , "Executable: " ++ bin ] ++
    [ "Program synopsis: " ++ prettySynopsis synopsis | isJust synopsis ]
311 312

-- | Render the successful build of a library.
313 314 315 316 317 318 319 320 321
renderLibrary :: String -> String -> Maybe String -> String
renderLibrary name lib synopsis = renderBox $
    [ "Successfully built library " ++ name
    , "Library: " ++ lib ] ++
    [ "Library synopsis: " ++ prettySynopsis synopsis | isJust synopsis ]

prettySynopsis :: Maybe String -> String
prettySynopsis Nothing  = ""
prettySynopsis (Just s) = dropWhileEnd isPunctuation s ++ "."
322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385

-- | Render the given set of lines in an ASCII box. The minimum width and
-- whether to use Unicode symbols are hardcoded in the function's body.
--
-- >>> renderBox (words "lorem ipsum")
-- /----------\
-- | lorem    |
-- | ipsum    |
-- \----------/
renderBox :: [String] -> String
renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
  where
    -- Minimum total width of the box in characters
    minimumBoxWidth = 32

    -- TODO: Make this setting configurable? Setting to True by default seems
    -- to work poorly with many fonts.
    useUnicode = False

    -- Characters to draw the box
    (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
        | useUnicode = ('─', '│', '╭',  '╮', '╰', '╯', ' ')
        | otherwise  = ('-', '|', '/', '\\', '\\', '/', ' ')

    -- Box width, taking minimum desired length and content into account.
    -- The -4 is for the beginning and end pipe/padding symbols, as
    -- in "| xxx |".
    boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
      where
        maxContentLength = maximum (map length ls)

    renderLine l = concat
        [ [pipe, padding]
        , padToLengthWith boxContentWidth padding l
        , [padding, pipe] ]
      where
        padToLengthWith n filler x = x ++ replicate (n - length x) filler

    (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
                       , botLeft : dashes ++ [botRight] )
      where
        -- +1 for each non-dash (= corner) char
        dashes = replicate (boxContentWidth + 2) dash

-- | Render the given set of lines next to our favorite unicorn Robert.
renderUnicorn :: [String] -> String
renderUnicorn ls =
    unlines $ take (max (length ponyLines) (length boxLines)) $
        zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
  where
    ponyLines :: [String]
    ponyLines = [ "                   ,;,,;'"
                , "                  ,;;'(    Robert the spitting unicorn"
                , "       __       ,;;' ' \\   wants you to know"
                , "     /'  '\\'~~'~' \\ /'\\.)  that a task      "
                , "  ,;(      )    /  |.  /   just finished!   "
                , " ,;' \\    /-.,,(   ) \\                      "
                , " ^    ) /       ) / )|     Almost there!    "
                , "      ||        ||  \\)                      "
                , "      (_\\       (_\\                         " ]
    ponyPadding :: String
    ponyPadding = "                                            "
    boxLines :: [String]
    boxLines = ["", "", ""] ++ (lines . renderBox $ ls)