Add --loud feature to bild

1 files changed, 129 insertions, 81 deletions

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index 0182a39..68ae588 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -128,7 +128,7 @@ import qualified Data.Char as Char
 import qualified Data.List as List
 import qualified Data.String as String
 import qualified Data.Text as Text
-import Rainbow (chunk, fore, green, putChunkLn, red)
+import Rainbow (Chunk, chunk, fore, green, putChunkLn, red)
 import qualified System.Directory as Dir
 import qualified System.Environment as Env
 import qualified System.Exit as Exit
@@ -146,7 +146,12 @@ main = Cli.main <| Cli.Plan help move test
         /> catMaybes
         /> filter isBuildableNs
         >>= mapM analyze
-        >>= mapM_ (build (args `Cli.has` Cli.longOption "test"))
+        >>= mapM
+          ( build
+              (args `Cli.has` Cli.longOption "test")
+              (args `Cli.has` Cli.longOption "loud")
+          )
+        >>= exitSummary
 
 help :: Cli.Docopt
 help =
@@ -155,12 +160,23 @@ bild
 
 Usage:
   bild test
-  bild [--test] <target>...
+  bild --help
+  bild [--test] [--loud]  <target>...
 
 Options:
   --test  Run tests on a target after building.
+  --loud  Show all output from compiler.
+  --help  Print this info
 |]
 
+exitSummary :: [Exit.ExitCode] -> IO ()
+exitSummary exits =
+  if failures > 0
+    then Exit.die <| show failures
+    else Exit.exitSuccess
+  where
+    failures = length <| filter isFailure exits
+
 type Dep = String
 
 type Out = String
@@ -290,8 +306,12 @@ detectGhcCompiler _ content
 jsSuffix :: String -> Bool
 jsSuffix = List.isSuffixOf ".js"
 
-build :: Bool -> Target -> IO ()
-build andTest target@Target {..} = do
+isFailure :: Exit.ExitCode -> Bool
+isFailure (Exit.ExitFailure _) = True
+isFailure Exit.ExitSuccess = False
+
+build :: Bool -> Bool -> Target -> IO Exit.ExitCode
+build andTest loud target@Target {..} = do
   root <- Env.getEnv "BIZ_ROOT"
   case compiler of
     GhcExe -> do
@@ -299,119 +319,147 @@ build andTest target@Target {..} = do
       let outDir = root </> "_/bild/dev/bin"
       Dir.createDirectoryIfMissing True outDir
       putText <| "bild:  dev:  bilder: " <> Text.pack builder
-      Process.callProcess
-        "ghc"
-        [ "-Werror",
-          "-i" <> root,
-          "-odir",
-          root </> "_/bild/int",
-          "-hidir",
-          root </> "_/bild/int",
-          "--make",
-          path,
-          "-main-is",
-          Namespace.toHaskellModule namespace,
-          "-o",
-          outDir </> out
-        ]
+      exitcode <-
+        proc
+          loud
+          "ghc"
+          [ "-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
       when andTest <| do
         Process.readProcessWithExitCode (outDir </> out) ["test"] "" >>= \case
           (Exit.ExitSuccess, _, _) ->
             putChunkLn <| fore green <| "test:  " <> nschunk namespace
-          (Exit.ExitFailure _, out, err) -> do
+          (Exit.ExitFailure _, stdout_, stderr_) -> do
             putChunkLn <| fore red <| "test:  " <> nschunk namespace
-            when (out /= mempty) <| putStr out
-            when (err /= mempty) <| putStr err
+            when (stdout_ /= mempty) <| putStr stdout_
+            when (stderr_ /= mempty) <| putStr stderr_
+      return exitcode
     GhcLib -> do
       putStrLn <| "bild:  dev:  ghc-lib: " <> Namespace.toPath namespace
       putText <| "bild:  dev:  bilder: " <> Text.pack builder
-      Process.callProcess
-        "ghc"
-        [ "-Werror",
-          "-i" <> root,
-          "-odir",
-          root </> "_/bild/int",
-          "-hidir",
-          root </> "_/bild/int",
-          "--make",
-          path
-        ]
+      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
     GhcjsExe -> do
       putStrLn <| "bild:  dev:  ghcjs-exe: " <> Namespace.toPath namespace
       let outDir = root </> "_/bild/dev/static"
       Dir.createDirectoryIfMissing True outDir
       putText <| "bild:  dev:  local: " <> Text.pack builder
-      Process.callProcess
-        "ghcjs"
-        [ "-Werror",
-          "-i" <> root,
-          "-odir",
-          root </> "_/bild/int",
-          "-hidir",
-          root </> "_/bild/int",
-          "--make",
-          path,
-          "-main-is",
-          Namespace.toHaskellModule namespace,
-          "-o",
-          outDir </> out
-        ]
+      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
     GhcjsLib -> do
       putStrLn <| "bild:  dev:  ghcjs-lib: " <> Namespace.toPath namespace
       putText <| "bild:  dev:  local: " <> Text.pack builder
-      Process.callProcess
-        "ghcjs"
-        [ "-Werror",
-          "-i" <> root,
-          "-odir",
-          root </> "_/bild/int",
-          "-hidir",
-          root </> "_/bild/int",
-          "--make",
-          path
-        ]
+      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
     Guile -> do
       putStrLn <| "bild:  dev:  guile: " <> Namespace.toPath namespace
       putText <| "bild:  dev:  local: " <> Text.pack builder
       putText "bild:  guile:  TODO"
       putText <| show target
+      return Exit.ExitSuccess
     NixBuild -> do
       putStrLn <| "bild:  nix:  " <> Namespace.toPath 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
-      Process.callProcess
-        "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
-        ]
+        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
     Copy -> do
       putStrLn <| "bild:  copy:  " <> Namespace.toPath namespace
       putText "bild:  copy:  TODO"
       putText <| show target
+      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
 
+nschunk :: Namespace -> Chunk
 nschunk = chunk <. Text.pack <. Namespace.toPath
 
 metaDep :: Regex.RE Char Dep