Capture command output and print it prettier

src/Bricoleur/Commands/Splice.hs

@@ -73,7 +73,7 @@ doReplacements root e original =
   where
     doReplace file frag = do
       new <- case findFragments root frag e of
-        Left err -> cError ("Fragment error: " % text) err
+        Left err -> cDie ("Fragment error: " % text) err
         Right x  -> x
       return (TL.replace (toIdent frag) new file)
 
@@ -81,8 +81,8 @@ readSection :: FilePath -> T.Text -> IO TL.Text
 readSection path f = do
   contents <- cOpenFile "section source" path
   case TL.breakOn (toIdent f) contents of
-    (_, "") -> cError ("Unable to find section " % shown %
-                       " in file " % string) f path
+    (_, "") -> cDie ("Unable to find section " % shown %
+                     " in file " % string) f path
     (_, rs) ->
       let (_, skipLine) = TL.breakOn "\n" rs
           (section, _) = TL.breakOn "«end»" (TL.drop 1 skipLine)

src/Bricoleur/Commands/Test.hs

@@ -3,6 +3,8 @@
 module Bricoleur.Commands.Test (runTest) where
 
 import           Control.Monad (forM_)
+import qualified Data.ByteString.Lazy.Char8 as B
+import qualified GHC.IO.Exception as Exn
 import           System.FilePath ((</>))
 import qualified System.FilePath as Sys
 import qualified System.Process as Sys
@@ -11,6 +13,7 @@ import Bricoleur.Opts
 import Bricoleur.Config
 import Bricoleur.Utils
 
+
 runTest :: Config -> Options -> IO ()
 runTest conf opts = do
   let root = Sys.takeDirectory (optFile opts)
@@ -19,11 +22,25 @@ runTest conf opts = do
     cDebug ("- running test for " % stext) (sourceName samp)
     runCommand root samp
 
+
 runCommand :: FilePath -> Source -> IO ()
 runCommand root src = do
   forM_ (sourceCommands src) $ \ln -> do
     let dir = root </> sourceDir src
-    cDebug ("  - $ " % shown % " in " % string) ln dir
-    let process = (Sys.shell ln) { Sys.cwd = Just (root </> sourceDir src) }
-    (_, _, _, h) <- Sys.createProcess process
-    Sys.waitForProcess h
+    cDebug ("  $ " % string % " (in " % string % ")") ln dir
+    (outH, inH) <- Sys.createPipe
+    let process = (Sys.shell ln) { Sys.cwd = Just (root </> sourceDir src)
+                                 , Sys.std_out = Sys.UseHandle inH
+                                 , Sys.std_err = Sys.UseHandle inH
+                                 }
+    (_, _, _, p) <- Sys.createProcess process
+    bufOutput <- B.hGetContents outH
+    code <- Sys.waitForProcess p
+    case code of
+      Exn.ExitSuccess -> return ()
+      Exn.ExitFailure n -> do
+        let idtext = map (B.append "  - ") (B.lines bufOutput)
+        cError ("\nCommand '" % string %
+                "' exited with error (" % shown %
+                ")") ln n
+        mapM_ bsErrorLn idtext

src/Bricoleur/Opts.hs

@@ -21,7 +21,7 @@ data Options = Options
   } deriving (Eq, Show)
 
 desc :: String
-desc = "FINISH ME"
+desc = "Bricoleur: a tool for testing and stiching code into documents"
 
 opts :: Opt.ParserInfo Options
 opts = Opt.info (p Opt.<**> Opt.helper)

src/Bricoleur/Utils.hs

@@ -5,6 +5,8 @@ module Bricoleur.Utils
 , cDebug
 , cWarn
 , cError
+, cDie
+, bsErrorLn
 
 , cOpenFile
 
@@ -19,6 +21,7 @@ module Bricoleur.Utils
 ) where
 
 import qualified Formatting as F
+import qualified Data.ByteString.Lazy.Char8 as BS
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TL
 import qualified Data.Text.Lazy.IO as TL
@@ -30,22 +33,27 @@ import qualified System.Posix.Terminal as Posix
 
 import Prelude (FilePath, IO, Either(Left), ($))
 
+-- | Produce a 'Left' value from a format string
 throw :: F.Format (Either TL.Text r) a -> a
 throw f =
   F.runFormat f (\ b -> Left (TL.toLazyText b))
 
+
 stderr :: TL.Text -> IO ()
 stderr = TL.hPutStr Sys.stderr
 
+
 -- | Write output to stdout
 cOutput :: TL.Text -> IO ()
 cOutput = TL.putStrLn
 
+
 -- | Write a debug message to stderr.
 cDebug :: F.Format (IO ()) a -> a
 cDebug msg = F.runFormat msg $ \ b ->
   TL.hPutStrLn Sys.stderr (TL.toLazyText b)
 
+
 -- | Write a warning message to stderr. If we are connected to a TTY,
 -- then this will write in an orange color.
 cWarn :: F.Format (IO ()) a -> a
@@ -57,9 +65,10 @@ cWarn msg = F.runFormat msg $ \b -> do
             stderr "\x1b[39m\n"
     else TL.hPutStrLn Sys.stderr (TL.toLazyText b)
 
+
 -- | Write an error message to stderr and exit. If we are connected to
 -- a TTY, this message will be in red.
-cError :: F.Format (IO r) a -> a
+cError :: F.Format (IO ()) a -> a
 cError msg = F.runFormat msg $ \b -> do
   isTTY <- Posix.queryTerminal Posix.stdOutput
   if isTTY
@@ -67,13 +76,33 @@ cError msg = F.runFormat msg $ \b -> do
             stderr (TL.toLazyText b)
             stderr "\x1b[39m\n"
     else TL.hPutStrLn Sys.stderr (TL.toLazyText b)
+
+-- | Write an error message to stderr and exit. If we are connected to
+-- a TTY, this message will be in red.
+cDie :: F.Format (IO r) a -> a
+cDie msg = F.runFormat msg $ \ b -> do
+  isTTY <- Posix.queryTerminal Posix.stdOutput
+  if isTTY
+    then do stderr "\x1b[91m"
+            stderr (TL.toLazyText b)
+            stderr "\x1b[39m\n"
+    else TL.hPutStrLn Sys.stderr (TL.toLazyText b)
   Sys.exitFailure
 
 
+bsErrorLn :: BS.ByteString -> IO ()
+bsErrorLn bs = do
+  isTTY <- Posix.queryTerminal Posix.stdOutput
+  if isTTY
+    then do BS.hPutStr Sys.stderr "\x1b[91m"
+            BS.hPutStr Sys.stderr bs
+            BS.hPutStr Sys.stderr "\x1b[39m\n"
+    else BS.hPutStrLn Sys.stderr bs
+
 cOpenFile :: TL.Text -> FilePath -> IO TL.Text
 cOpenFile purpose path = do
   exists <- Sys.doesFileExist path
   if exists
     then TL.readFile path
-    else cError ("Unable to open " F.% F.text F.%
-                 " file at " F.% F.string) purpose path
+    else cDie ("Unable to open " F.% F.text F.%
+               " file at " F.% F.string) purpose path