Commit c7c45fc3 authored by Moritz Angermann's avatar Moritz Angermann
Browse files

Move rendering to Actions.

parent ee95b14e
......@@ -20,8 +20,7 @@ module Base (
bootPackageConstraints, packageDependencies,
-- * Output
putColoured, putOracle, putBuild, putBuildInfo, putSuccess, putError,
renderAction, renderLibrary, renderProgram,
putColoured, putOracle, putBuild, putSuccess, putError,
-- * Miscellaneous utilities
bimap, minusOrd, intersectOrd, replaceEq, quote, replaceSeparators,
......@@ -42,7 +41,6 @@ import Development.Shake.FilePath
import System.Console.ANSI
import qualified System.Directory as IO
import System.IO
import Oracles.Config.CmdLineFlag (buildInfo, BuildInfoFlag(..))
-- TODO: reexport Stage, etc.?
......@@ -131,11 +129,6 @@ putOracle = putColoured Blue
putBuild :: String -> Action ()
putBuild = putColoured White
-- | Switch for @putBuild@ filtered through @buildInfo@
putBuildInfo :: String -> Action ()
putBuildInfo s | buildInfo /= None = putBuild s
putBuildInfo _ = pure ()
-- | A more colourful version of success message
putSuccess :: String -> Action ()
putSuccess = putColoured Green
......@@ -146,95 +139,6 @@ putError msg = do
putColoured Red msg
error $ "GHC build system error: " ++ msg
-- | Render an action.
renderAction :: String -> String -> String -> String
renderAction what input output = case buildInfo of
Normal -> renderBox [ what
, " input:" ++ input
, " => output:" ++ output ]
Brief -> "> " ++ what ++ ": " ++ input ++ " => " ++ output
Unicorn -> renderPony [ what
, " input:" ++ input
, " => output:" ++ output ]
None -> ""
-- | 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: " ++ synopsis ++ "."]
-- | Render the successful built of a library
renderLibrary :: String -> String -> String -> String
renderLibrary name lib synopsis = renderBox [ "Successfully built library " ++ name
, "Library: " ++ lib
, "Library synopsis: " ++ synopsis ++ "."]
-- | Render the given set of lines next to our favorit unicorn Robert.
renderPony :: [String] -> String
renderPony 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)
-- | Render the given set of lines in a nice box of ASCII.
--
-- 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
-- FIXME: See Shake #364.
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
-- Explicit definition to avoid dependency on Data.Bifunctor
-- | Bifunctor bimap.
bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
......
{-# LANGUAGE RecordWildCards #-}
module Rules.Actions (
build, buildWithResources, copyFile, createDirectory, removeDirectory, moveDirectory,
fixFile, runConfigure, runMake, applyPatch, runBuilder, makeExecutable
fixFile, runConfigure, runMake, applyPatch, renderLibrary, renderProgram,
runBuilder, makeExecutable,
) where
import qualified System.Directory as IO
......@@ -15,6 +16,8 @@ import Settings.Args
import Settings.Builders.Ar
import qualified Target
import Oracles.Config.CmdLineFlag (buildInfo, BuildInfoFlag(..))
-- Build a given target using an appropriate builder and acquiring necessary
-- resources. Force a rebuilt if the argument list has changed since the last
-- built (that is, track changes in the build system).
......@@ -64,7 +67,7 @@ captureStdout target path argList = do
copyFile :: FilePath -> FilePath -> Action ()
copyFile source target = do
putBuildInfo $ renderAction "Copy file" source target
putProgressInfo $ renderAction "Copy file" source target
copyFileChanged source target
createDirectory :: FilePath -> Action ()
......@@ -80,7 +83,7 @@ removeDirectory dir = do
-- Note, the source directory is untracked
moveDirectory :: FilePath -> FilePath -> Action ()
moveDirectory source target = do
putBuildInfo $ renderAction "Move directory" source target
putProgressInfo $ renderAction "Move directory" source target
liftIO $ IO.renameDirectory source target
-- Transform a given file by applying a function to its contents
......@@ -132,7 +135,7 @@ makeExecutable file = do
-- Print out key information about the command being executed
putInfo :: Target.Target -> Action ()
putInfo Target.Target {..} = putBuildInfo $ renderAction
putInfo Target.Target {..} = putProgressInfo $ renderAction
("Run " ++ show builder ++ " (" ++ stageInfo
++ "package = " ++ pkgNameString package ++ wayInfo ++ ")")
(digest inputs)
......@@ -143,3 +146,99 @@ putInfo Target.Target {..} = putBuildInfo $ renderAction
digest [] = "none"
digest [x] = x
digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
-- | Switch for @putBuild@ filtered through @buildInfo@
putProgressInfo :: String -> Action ()
putProgressInfo s | buildInfo /= None = putBuild s
putProgressInfo _ = pure ()
-- | Render an action.
renderAction :: String -> String -> String -> String
renderAction what input output = case buildInfo of
Normal -> renderBox [ what
, " input: " ++ input
, " => output: " ++ output ]
Brief -> "> " ++ what ++ ": " ++ input ++ " => " ++ output
Unicorn -> renderUnicorn [ what
, " input: " ++ input
, " => output: " ++ output ]
None -> ""
-- | 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: " ++ synopsis ++ "."]
-- | Render the successful built of a library
renderLibrary :: String -> String -> String -> String
renderLibrary name lib synopsis = renderBox [ "Successfully built library " ++ name
, "Library: " ++ lib
, "Library synopsis: " ++ synopsis ++ "."]
-- | Render the given set of lines next to our favorit 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)
-- | Render the given set of lines in a nice box of ASCII.
--
-- 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
-- FIXME: See Shake #364.
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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment