diff options
Diffstat (limited to 'hadrian/src/Hadrian/Utilities.hs')
| -rw-r--r-- | hadrian/src/Hadrian/Utilities.hs | 489 |
1 files changed, 489 insertions, 0 deletions
diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs new file mode 100644 index 0000000000..88b5bad911 --- /dev/null +++ b/hadrian/src/Hadrian/Utilities.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE TypeFamilies #-} +module Hadrian.Utilities ( + -- * List manipulation + fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize, + + -- * String manipulation + quote, yesNo, parseYesNo, zeroOne, + + -- * FilePath manipulation + unifyPath, (-/-), + + -- * Accessing Shake's type-indexed map + insertExtra, lookupExtra, userSetting, + + -- * Paths + BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource, + + -- * File system operations + copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile, + createDirectory, copyDirectory, moveDirectory, removeDirectory, + + -- * Diagnostic info + UseColour (..), Colour (..), ANSIColour (..), putColoured, + BuildProgressColour, mkBuildProgressColour, putBuild, + SuccessColour, mkSuccessColour, putSuccess, + ProgressInfo (..), putProgressInfo, + renderAction, renderActionNoOutput, renderProgram, renderLibrary, renderBox, renderUnicorn, + + -- * Miscellaneous + (<&>), (%%>), cmdLineLengthLimit, + + -- * Useful re-exports + Dynamic, fromDynamic, toDyn, TypeRep, typeOf + ) where + +import Control.Monad.Extra +import Data.Char +import Data.Dynamic (Dynamic, fromDynamic, toDyn) +import Data.HashMap.Strict (HashMap) +import Data.List.Extra +import Data.Maybe +import Data.Typeable (TypeRep, typeOf) +import Development.Shake hiding (Normal) +import Development.Shake.Classes +import Development.Shake.FilePath +import System.Environment (lookupEnv) +import System.Info.Extra + +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 + +-- | 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 + +-- | @chunksOfSize size strings@ splits a given list of strings into chunks not +-- exceeding the given @size@. If that is impossible, it uses singleton chunks. +chunksOfSize :: Int -> [String] -> [[String]] +chunksOfSize n = repeatedly f + where + f xs = splitAt (max 1 $ length $ takeWhile (<= n) $ scanl1 (+) $ map length xs) xs + +-- | Add single quotes around a string. +quote :: String -> String +quote s = "'" ++ s ++ "'" + +-- | Pretty-print a 'Bool' as a @"YES"@ or @"NO"@ string. +yesNo :: Bool -> String +yesNo True = "YES" +yesNo False = "NO" + +-- | Parse a 'Bool' from a @"YES"@ or @"NO"@ string. Returns @Nothing@ in case +-- of a parse failure. +parseYesNo :: String -> Maybe Bool +parseYesNo "YES" = Just True +parseYesNo "NO" = Just False +parseYesNo _ = Nothing + +-- | Pretty-print a 'Bool' as a @"0"@ or @"1"@ string +zeroOne :: Bool -> String +zeroOne False = "0" +zeroOne True = "1" + +-- | 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 -/- + +-- | 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 %%> + +-- | Build command lines can get very long; for example, when building the Cabal +-- library, they can reach 2MB! Some operating systems do not support command +-- lines of such length, and this function can be used to obtain a reasonable +-- approximation of the limit. On Windows, it is theoretically 32768 characters +-- (since Windows 7). In practice we use 31000 to leave some breathing space for +-- the builder path & name, auxiliary flags, and other overheads. On Mac OS X, +-- ARG_MAX is 262144, yet when using @xargs@ on OSX this is reduced by over +-- 20000. Hence, 200000 seems like a sensible limit. On other operating systems +-- we currently use the 4194304 setting. +cmdLineLengthLimit :: Int +cmdLineLengthLimit | isWindows = 31000 + | isMac = 200000 + | otherwise = 4194304 + +-- | 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 value in Shake's type-indexed map. +lookupExtra :: Typeable a => a -> Map.HashMap TypeRep Dynamic -> a +lookupExtra defaultValue extra = fromMaybe defaultValue maybeValue + where + maybeValue = fromDynamic =<< Map.lookup (typeOf defaultValue) extra + +-- | 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 + return $ lookupExtra defaultValue extra + +-- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the +-- setting is not found, return the provided default value instead. +userSettingRules :: Typeable a => a -> Rules a +userSettingRules defaultValue = do + extra <- shakeExtra <$> getShakeOptionsRules + return $ lookupExtra defaultValue extra + +newtype BuildRoot = BuildRoot FilePath deriving (Typeable, Eq, Show) + +-- | All build results are put into the 'buildRoot' directory. +buildRoot :: Action FilePath +buildRoot = do + BuildRoot path <- userSetting (BuildRoot "") + return path + +buildRootRules :: Rules FilePath +buildRootRules = do + BuildRoot path <- userSettingRules (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 <&> + +-- | 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) + +-- | 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 + quietly $ copyFileChanged source target + +-- | 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 + putProgressInfo $ "| Fix " ++ file + 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 + putProgressInfo $ "| Make " ++ quote file ++ " executable." + 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 + putProgressInfo $ "| Remove file " ++ file + liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file + +-- | Create a directory if it does not already exist. +createDirectory :: FilePath -> Action () +createDirectory dir = do + putProgressInfo $ "| Create directory " ++ dir + 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 + putProgressInfo $ "| Remove directory " ++ dir + liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir + +data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable) + +-- | Terminal output colours +data Colour + = Dull ANSIColour -- ^ 8-bit ANSI colours + | Vivid ANSIColour -- ^ 16-bit vivid ANSI colours + | Extended String -- ^ Extended 256-bit colours, manual code stored + +-- | ANSI terminal colours +data ANSIColour + = Black -- ^ ANSI code: 30 + | Red -- ^ 31 + | Green -- ^ 32 + | Yellow -- ^ 33 + | Blue -- ^ 34 + | Magenta -- ^ 35 + | Cyan -- ^ 36 + | White -- ^ 37 + | Reset -- ^ 0 + +-- | Convert ANSI colour names into their associated codes +colourCode :: ANSIColour -> String +colourCode Black = "30" +colourCode Red = "31" +colourCode Green = "32" +colourCode Yellow = "33" +colourCode Blue = "34" +colourCode Magenta = "35" +colourCode Cyan = "36" +colourCode White = "37" +colourCode Reset = "0" + +-- | Create the final ANSI code. +mkColour :: Colour -> String +mkColour (Dull c) = colourCode c +mkColour (Vivid c) = colourCode c ++ ";1" +mkColour (Extended code) = "38;5;" ++ code + +-- | A more colourful version of Shake's 'putNormal'. +putColoured :: String -> String -> Action () +putColoured code msg = do + useColour <- userSetting Never + supported <- liftIO $ (&&) <$> IO.hIsTerminalDevice IO.stdout + <*> (not <$> isDumb) + let c Never = False + c Auto = supported || IO.isWindows -- Colours do work on Windows + c Always = True + if c useColour + then putNormal $ "\ESC[" ++ code ++ "m" ++ msg ++ "\ESC[0m" + else putNormal msg + where + isDumb = maybe False (== "dumb") <$> lookupEnv "TERM" + +newtype BuildProgressColour = BuildProgressColour String + deriving Typeable + +-- | Generate an encoded colour for progress output from names. +mkBuildProgressColour :: Colour -> BuildProgressColour +mkBuildProgressColour c = BuildProgressColour $ mkColour c + +-- | Default 'BuildProgressColour'. +magenta :: BuildProgressColour +magenta = mkBuildProgressColour (Dull Magenta) + +-- | Print a build progress message (e.g. executing a build command). +putBuild :: String -> Action () +putBuild msg = do + BuildProgressColour code <- userSetting magenta + putColoured code msg + +newtype SuccessColour = SuccessColour String + deriving Typeable + +-- | Generate an encoded colour for successful output from names +mkSuccessColour :: Colour -> SuccessColour +mkSuccessColour c = SuccessColour $ mkColour c + +-- | Default 'SuccessColour'. +green :: SuccessColour +green = mkSuccessColour (Dull Green) + +-- | Print a success message (e.g. a package is built successfully). +putSuccess :: String -> Action () +putSuccess msg = do + SuccessColour code <- userSetting green + putColoured code msg + +data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable) + +-- | Version of 'putBuild' controlled by @--progress-info@ command line argument. +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 Brief + 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 an action. +renderActionNoOutput :: String -> FilePath -> Action String +renderActionNoOutput what input = do + progressInfo <- userSetting Brief + return $ case progressInfo of + None -> "" + Brief -> "| " ++ what ++ ": " ++ i + Normal -> renderBox [ what, " input: " ++ i ] + Unicorn -> renderUnicorn [ what, " input: " ++ i ] + where + i = unifyPath input + +-- | Render the successful build of a program. +renderProgram :: String -> String -> String -> String +renderProgram name bin synopsis = renderBox $ + [ "Successfully built program " ++ name + , "Executable: " ++ bin ] ++ + [ "Program synopsis: " ++ endWithADot synopsis | not (null synopsis) ] + +-- | Render the successful build of a library. +renderLibrary :: String -> String -> String -> String +renderLibrary name lib synopsis = renderBox $ + [ "Successfully built library " ++ name + , "Library: " ++ lib ] ++ + [ "Library synopsis: " ++ endWithADot synopsis | not (null synopsis) ] + +endWithADot :: String -> String +endWithADot s = dropWhileEnd isPunctuation s ++ "." + +-- | 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) |