Move rendering to Actions.
authorMoritz Angermann <moritz.angermann@gmail.com>
Fri, 15 Jan 2016 13:36:36 +0000 (21:36 +0800)
committerMoritz Angermann <moritz.angermann@gmail.com>
Fri, 15 Jan 2016 13:36:36 +0000 (21:36 +0800)
src/Base.hs
src/Rules/Actions.hs

index 68a223b..37f4716 100644 (file)
@@ -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)
index 4021358..a0a88ff 100644 (file)
@@ -1,7 +1,8 @@
 {-# 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