Better bild output

- structured log messages
- compact logs rewrite the line on bild completion
- using conduit for streaming output (although I think this isn't working quite
  right)
- new Proc type for running subprocesses
- general code cleanup and refactoring

2 files changed, 168 insertions, 119 deletions

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index 68ae588..ab6f5bb 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -7,6 +7,8 @@
 -- | A general purpose build tool.
 --
 -- : out bild
+-- : dep conduit
+-- : dep conduit-extra
 -- : dep docopt
 -- : dep regex-applicative
 -- : dep rainbow
@@ -124,16 +126,21 @@ import Biz.Namespace (Namespace (..))
 import qualified Biz.Namespace as Namespace
 import Biz.Test ((@=?))
 import qualified Biz.Test as Test
+import qualified Control.Concurrent.Async as Async
 import qualified Data.Char as Char
+import Data.Conduit ((.|))
+import qualified Data.Conduit as Conduit
+import qualified Data.Conduit.List as Conduit
+import qualified Data.Conduit.Process as Conduit
 import qualified Data.List as List
 import qualified Data.String as String
 import qualified Data.Text as Text
-import Rainbow (Chunk, chunk, fore, green, putChunkLn, red)
+import Rainbow (chunk, fore, green, putChunk, red, white, yellow)
 import qualified System.Directory as Dir
 import qualified System.Environment as Env
 import qualified System.Exit as Exit
 import System.FilePath ((</>))
-import qualified System.Process as Process
+import qualified System.IO as IO
 import qualified Text.Regex.Applicative as Regex
 import qualified Prelude
 
@@ -142,7 +149,8 @@ main = Cli.main <| Cli.Plan help move test
   where
     test = Test.group "Biz.Bild" [Test.unit "id" <| 1 @=? (1 :: Integer)]
     move args =
-      mapM getNamespace (Cli.getAllArgs args (Cli.argument "target"))
+      IO.hSetBuffering stdout IO.NoBuffering
+        >> mapM getNamespace (Cli.getAllArgs args (Cli.argument "target"))
         /> catMaybes
         /> filter isBuildableNs
         >>= mapM analyze
@@ -160,8 +168,7 @@ bild
 
 Usage:
   bild test
-  bild --help
-  bild [--test] [--loud]  <target>...
+  bild [options] <target>...
 
 Options:
   --test  Run tests on a target after building.
@@ -311,17 +318,17 @@ isFailure (Exit.ExitFailure _) = True
 isFailure Exit.ExitSuccess = False
 
 build :: Bool -> Bool -> Target -> IO Exit.ExitCode
-build andTest loud target@Target {..} = do
+build andTest loud Target {..} = do
   root <- Env.getEnv "BIZ_ROOT"
   case compiler of
     GhcExe -> do
-      putStrLn <| "bild:  dev:  ghc-exe: " <> Namespace.toPath namespace
+      msg Info ["bild", "dev", "ghc-exe", nschunk namespace]
       let outDir = root </> "_/bild/dev/bin"
       Dir.createDirectoryIfMissing True outDir
-      putText <| "bild:  dev:  bilder: " <> Text.pack builder
       exitcode <-
         proc
           loud
+          namespace
           "ghc"
           [ "-Werror",
             "-i" <> root,
@@ -336,131 +343,171 @@ build andTest loud target@Target {..} = do
             "-o",
             outDir </> out
           ]
-      putChunkLn <| fore green <| "bilt:  " <> nschunk namespace
-      when andTest <| do
-        Process.readProcessWithExitCode (outDir </> out) ["test"] "" >>= \case
-          (Exit.ExitSuccess, _, _) ->
-            putChunkLn <| fore green <| "test:  " <> nschunk namespace
-          (Exit.ExitFailure _, stdout_, stderr_) -> do
-            putChunkLn <| fore red <| "test:  " <> nschunk namespace
-            when (stdout_ /= mempty) <| putStr stdout_
-            when (stderr_ /= mempty) <| putStr stderr_
-      return exitcode
+      if andTest
+        then
+          run
+            <| Proc
+              { loud = loud,
+                cmd = outDir </> out,
+                args = ["test"],
+                ns = namespace,
+                onFailure = msg Fail ["test", nschunk namespace] >> br,
+                onSuccess = msg Pass ["test", nschunk namespace] >> br
+              }
+        else return exitcode
     GhcLib -> do
-      putStrLn <| "bild:  dev:  ghc-lib: " <> Namespace.toPath namespace
-      putText <| "bild:  dev:  bilder: " <> Text.pack builder
-      exitcode <-
-        proc
-          loud
-          "ghc"
-          [ "-Werror",
-            "-i" <> root,
-            "-odir",
-            root </> "_/bild/int",
-            "-hidir",
-            root </> "_/bild/int",
-            "--make",
-            path
-          ]
-      putChunkLn <| fore green <| "bilt:  " <> nschunk namespace
-      return exitcode
+      msg Info ["bild", "dev", "ghc-lib", nschunk namespace]
+      proc
+        loud
+        namespace
+        "ghc"
+        [ "-Werror",
+          "-i" <> root,
+          "-odir",
+          root </> "_/bild/int",
+          "-hidir",
+          root </> "_/bild/int",
+          "--make",
+          path
+        ]
     GhcjsExe -> do
-      putStrLn <| "bild:  dev:  ghcjs-exe: " <> Namespace.toPath namespace
+      msg Info ["bild", "dev", "ghcjs-exe", nschunk namespace]
       let outDir = root </> "_/bild/dev/static"
       Dir.createDirectoryIfMissing True outDir
-      putText <| "bild:  dev:  local: " <> Text.pack builder
-      exitcode <-
-        proc
-          loud
-          "ghcjs"
-          [ "-Werror",
-            "-i" <> root,
-            "-odir",
-            root </> "_/bild/int",
-            "-hidir",
-            root </> "_/bild/int",
-            "--make",
-            path,
-            "-main-is",
-            Namespace.toHaskellModule namespace,
-            "-o",
-            outDir </> out
-          ]
-      putChunkLn <| fore green <| "bilt:  " <> nschunk namespace
-      return exitcode
+      proc
+        loud
+        namespace
+        "ghcjs"
+        [ "-Werror",
+          "-i" <> root,
+          "-odir",
+          root </> "_/bild/int",
+          "-hidir",
+          root </> "_/bild/int",
+          "--make",
+          path,
+          "-main-is",
+          Namespace.toHaskellModule namespace,
+          "-o",
+          outDir </> out
+        ]
     GhcjsLib -> do
-      putStrLn <| "bild:  dev:  ghcjs-lib: " <> Namespace.toPath namespace
-      putText <| "bild:  dev:  local: " <> Text.pack builder
-      exitcode <-
-        proc
-          loud
-          "ghcjs"
-          [ "-Werror",
-            "-i" <> root,
-            "-odir",
-            root </> "_/bild/int",
-            "-hidir",
-            root </> "_/bild/int",
-            "--make",
-            path
-          ]
-      putChunkLn <| fore green <| "bilt:  " <> nschunk namespace
-      return exitcode
+      msg Info ["bild", "dev", "ghcjs-lib", nschunk namespace]
+      proc
+        loud
+        namespace
+        "ghcjs"
+        [ "-Werror",
+          "-i" <> root,
+          "-odir",
+          root </> "_/bild/int",
+          "-hidir",
+          root </> "_/bild/int",
+          "--make",
+          path
+        ]
     Guile -> do
-      putStrLn <| "bild:  dev:  guile: " <> Namespace.toPath namespace
-      putText <| "bild:  dev:  local: " <> Text.pack builder
-      putText "bild:  guile:  TODO"
-      putText <| show target
+      msg Warn ["bild", "guile", "TODO", nschunk namespace]
       return Exit.ExitSuccess
     NixBuild -> do
-      putStrLn <| "bild:  nix:  " <> Namespace.toPath namespace
+      msg
+        Info
+        [ "bild",
+          "nix",
+          if null builder
+            then "local"
+            else builder,
+          nschunk namespace
+        ]
       let outDir = root </> "_/bild/nix"
       Dir.createDirectoryIfMissing True outDir
-      if null builder
-        then putText <| "bild:  nix:  local"
-        else
-          putText <| "bild:  nix:  remote: "
-            <> Text.pack builder
-      exitcode <-
-        proc
-          loud
-          "nix-build"
-          [ path,
-            "-o",
-            outDir </> Namespace.toPath namespace,
-            -- Set default arguments to nix functions
-            "--arg",
-            "bild",
-            "import " <> root
-              </> "Biz/Bild/Rules.nix"
-              <> " { nixpkgs = import "
-              <> root
-              </> "Biz/Bild/Nixpkgs.nix"
-              <> "; }",
-            "--arg",
-            "lib",
-            "(import " <> root </> "Biz/Bild/Nixpkgs.nix).lib",
-            "--builders",
-            builder
-          ]
-      putChunkLn <| fore green <| "bilt:  " <> nschunk namespace
-      return exitcode
+      proc
+        loud
+        namespace
+        "nix-build"
+        [ path,
+          "-o",
+          outDir </> Namespace.toPath namespace,
+          -- Set default arguments to nix functions
+          "--arg",
+          "bild",
+          "import " <> root
+            </> "Biz/Bild/Rules.nix"
+            <> " { nixpkgs = import "
+            <> root
+            </> "Biz/Bild/Nixpkgs.nix"
+            <> "; }",
+          "--arg",
+          "lib",
+          "(import " <> root </> "Biz/Bild/Nixpkgs.nix).lib",
+          "--builders",
+          builder
+        ]
     Copy -> do
-      putStrLn <| "bild:  copy:  " <> Namespace.toPath namespace
-      putText "bild:  copy:  TODO"
-      putText <| show target
+      msg Warn ["bild", "copy", "TODO", nschunk namespace]
       return Exit.ExitSuccess
 
--- | Run a subprocess, handling output appropriately.
-proc :: Bool -> String -> [String] -> IO Exit.ExitCode
-proc loud cmd args = do
-  (exitcode, stdout_, stderr_) <- Process.readProcessWithExitCode cmd args ""
-  when loud <| putStr <| stdout_ ++ stderr_
-  when (isFailure exitcode) <| putStr <| stdout_ ++ stderr_
-  return exitcode
+data Proc = Proc
+  { loud :: Bool,
+    cmd :: String,
+    args :: [String],
+    ns :: Namespace,
+    onFailure :: IO (),
+    onSuccess :: IO ()
+  }
+
+-- | Run a subprocess, streaming output if --loud is set.
+run :: Proc -> IO Exit.ExitCode
+run Proc {..} = do
+  (Conduit.Inherited, stdout_, stderr_, cph) <- Conduit.streamingProcess <| Conduit.proc cmd args
+  exitcode <-
+    if loud
+      then
+        Async.runConcurrently
+          <| Async.Concurrently (puts stdout_)
+          *> (Async.Concurrently <| Conduit.waitForStreamingProcess cph)
+      else Async.runConcurrently <| Async.Concurrently <| Conduit.waitForStreamingProcess cph
+  if isFailure exitcode
+    then puts stderr_ >> onFailure >> return exitcode
+    else onSuccess >> return exitcode
+
+-- | Helper for running a standard bild subprocess.
+proc :: Bool -> Namespace -> String -> [String] -> IO Exit.ExitCode
+proc loud namespace cmd args =
+  run
+    <| Proc
+      { loud = loud,
+        ns = namespace,
+        cmd = cmd,
+        args = args,
+        onFailure = msg Fail ["bild", nschunk namespace] >> br,
+        onSuccess = msg Good ["bild", nschunk namespace] >> br
+      }
+
+data Lvl = Good | Pass | Info | Warn | Fail
+
+msg :: Lvl -> [String] -> IO ()
+msg lvl labels = putChunk <| fore color <| clear <> txt <> "\r"
+  where
+    txt = chunk <| Text.pack <| joinWith gap (label : labels)
+    (color, label) = case lvl of
+      Good -> (green, "good")
+      Pass -> (green, "pass")
+      Info -> (white, "info")
+      Warn -> (yellow, "warn")
+      Fail -> (red, "fail")
+    gap = ":  "
+    clear = "\ESC[2K"
+
+br :: IO ()
+br = putChunk "\n"
+
+-- | Helper for printing during a subprocess
+puts :: Conduit.ConduitM () ByteString IO () -> IO ()
+puts thing = Conduit.runConduit <| thing .| Conduit.mapM_ putStr
 
-nschunk :: Namespace -> Chunk
-nschunk = chunk <. Text.pack <. Namespace.toPath
+nschunk :: Namespace -> String
+nschunk = Namespace.toPath
 
 metaDep :: Regex.RE Char Dep
 metaDep = Regex.string "-- : dep " *> Regex.many (Regex.psym Char.isAlpha)
diff --git a/Biz/Bild/Deps/Haskell.nix b/Biz/Bild/Deps/Haskell.nix
index 21fcb66..4434cb3 100644
--- a/Biz/Bild/Deps/Haskell.nix
+++ b/Biz/Bild/Deps/Haskell.nix
@@ -11,6 +11,8 @@ with hpkgs;
   clay
   cmark
   cmark-lucid
+  conduit
+  conduit-extra
   config-ini
   containers
   directory