Merge pull request #37 from apauley/output-usability

Improve Command Output

Author: apauley

.travis.yml

@@ -41,7 +41,8 @@ install:
   - stack setup --interleaved-output
   - stack exec -- ghc --version
 
-  - stack build --interleaved-output --test --bench --no-run-tests --no-run-benchmarks --pedantic
+  - stack build --interleaved-output --pedantic
+  - stack build --interleaved-output --test --bench --no-run-tests --no-run-benchmarks
   - stack install
   - which hledger-flow
   - hledger-flow version
@@ -53,7 +54,7 @@ install:
   - git clone --recurse-submodules https://github.com/apauley/hledger-flow-example.git $HOME/hledger-flow-example
 
 script:
-  - stack test --interleaved-output --pedantic
+  - stack test --interleaved-output
   - if [[ "$TRAVIS_OS_NAME" == "linux" ]]; then git checkout HEAD package.yaml; fi
   - hledger-flow import --show-options --verbose $HOME/hledger-flow-example
   - hledger-flow report --show-options --verbose $HOME/hledger-flow-example

ChangeLog.md

@@ -1,5 +1,9 @@
 # Changelog for [hledger-flow](https://github.com/apauley/hledger-flow)
 
+## 0.11.2
+
+- Improved display of external process output
+
 ## 0.11.1.2
 
 - Exit with an error code when any external script fails - https://github.com/apauley/hledger-flow/issues/28

README.org

@@ -38,6 +38,17 @@ It started when I realized that the scripts I wrote while playing around
 with the ideas in [[https://github.com/adept/full-fledged-hledger/wiki][adept's Full-fledged Hledger]] aren't really specific to
 my own finances, and can be shared.
 
+* How do I install it?
+  :PROPERTIES:
+  :CUSTOM_ID: how-do-i-install-it
+  :END:
+
+The easiest way to get it running is to download [[https://github.com/apauley/hledger-flow/releases][the latest release]]
+for your OS, and copy the =hledger-flow= executable to a directory in your PATH.
+Then just run it and see what it tells you to do.
+
+You can also compile it yourself by following the [[#build-instructions][build instructions]].
+
 * Overview of the Basic Workflow
   :PROPERTIES:
   :CUSTOM_ID: overview-of-the-basic-workflow
@@ -524,7 +535,7 @@ script to do anything that the =preprocess= script would have done.
 Save your =construct= script in the account directory, e.g.
 =import/john/mybank/savings/construct=.
 
-=hledger-flow= will call your =construct= script with 4 positional
+=hledger-flow= will call your =construct= script with 5 positional
 parameters:
 
 1. The path to the input statement, e.g.
@@ -540,9 +551,11 @@ Your =construct= script is expected to:
 - generate your own =hledger= journal transactions
 - be idempotent. Running =construct= multiple times on the same files
   should produce the same result.
-- send all output to =stdout=. =hledger-flow= will pipe your output into
+- send all journals to =stdout=. =hledger-flow= will pipe your standard output into
   =hledger= which will format it and save it to an output file.
 
+You can still use =stderr= in your construct script for any other output that you may want to see.
+
 *** Stability of this Feature
     :PROPERTIES:
     :CUSTOM_ID: stability-of-this-feature-4

package.yaml

@@ -1,5 +1,5 @@
 name:                hledger-flow
-version:             0.11.1.2
+version:             0.11.2.0
 synopsis:            An hledger workflow focusing on automated statement import and classification.
 category:            Finance, Console
 license:             GPL-3

src/Hledger/Flow/CSVImport.hs

@@ -85,13 +85,11 @@ preprocess :: ImportOptions -> TChan FlowTypes.LogMessage -> FilePath -> Line ->
 preprocess opts ch script bank account owner src = do
   let csvOut = changePathAndExtension "2-preprocessed" "csv" src
   mktree $ directory csvOut
-  let script' = format fp script :: Text
-  let action = (parAwareProc opts) script' [format fp src, format fp csvOut, lineToText bank, lineToText account, lineToText owner] empty
+  let args = [format fp src, format fp csvOut, lineToText bank, lineToText account, lineToText owner]
   let relScript = relativeToBase opts script
   let relSrc = relativeToBase opts src
-  let msg = format ("executing '"%fp%"' on '"%fp%"'") relScript relSrc
-  ((_, stdOut, _), _) <- timeAndExitOnErr opts ch msg action
-  channelOut ch stdOut
+  let cmdLabel = format ("executing '"%fp%"' on '"%fp%"'") relScript relSrc
+  _ <- timeAndExitOnErr opts ch cmdLabel channelOut channelErr (parAwareProc opts) (format fp script, args, empty)
   return csvOut
 
 hledgerImport :: ImportOptions -> TChan FlowTypes.LogMessage -> FilePath -> FilePath -> IO FilePath
@@ -110,10 +108,9 @@ hledgerImport' opts ch importDirs csvSrc journalOut = do
     Just rf -> do
       let relRules = relativeToBase opts rf
       let hledger = format fp $ FlowTypes.hlPath . hledgerInfo $ opts :: Text
-      let action = (parAwareProc opts) hledger ["print", "--rules-file", format fp rf, "--file", format fp csvSrc, "--output-file", format fp journalOut] empty
-      let msg = format ("importing '"%fp%"' using rules file '"%fp%"'") relCSV relRules
-      ((_, stdOut, _), _) <- timeAndExitOnErr opts ch msg action
-      channelOut ch stdOut
+      let args = ["print", "--rules-file", format fp rf, "--file", format fp csvSrc, "--output-file", format fp journalOut]
+      let cmdLabel = format ("importing '"%fp%"' using rules file '"%fp%"'") relCSV relRules
+      _ <- timeAndExitOnErr opts ch cmdLabel channelOut channelErr (parAwareProc opts) (hledger, args, empty)
       return journalOut
     Nothing ->
       do
@@ -157,12 +154,13 @@ statementSpecificRulesFiles csvSrc importDirs = do
 customConstruct :: ImportOptions -> TChan FlowTypes.LogMessage -> FilePath -> Line -> Line -> Line -> FilePath -> FilePath -> IO FilePath
 customConstruct opts ch constructScript bank account owner csvSrc journalOut = do
   let script = format fp constructScript :: Text
-  let importOut = inproc script [format fp csvSrc, "-", lineToText bank, lineToText account, lineToText owner] empty
-  let hledger = format fp $ FlowTypes.hlPath . hledgerInfo $ opts :: Text
-  let action = (parAwareProc opts) hledger ["print", "--ignore-assertions", "--file", "-", "--output-file", format fp journalOut] importOut
   let relScript = relativeToBase opts constructScript
+  let constructArgs = [format fp csvSrc, "-", lineToText bank, lineToText account, lineToText owner]
+  let constructCmdText = format ("Running: "%fp%" "%s) relScript (showCmdArgs constructArgs)
+  let stdLines = inprocWithErrFun (channelErrLn ch) (script, constructArgs, empty)
+  let hledger = format fp $ FlowTypes.hlPath . hledgerInfo $ opts :: Text
+  let args = ["print", "--ignore-assertions", "--file", "-", "--output-file", format fp journalOut]
   let relSrc = relativeToBase opts csvSrc
-  let msg = format ("executing '"%fp%"' on '"%fp%"'") relScript relSrc
-  ((_, stdOut, _), _) <- timeAndExitOnErr opts ch msg action
-  channelOut ch stdOut
+  let cmdLabel = format ("executing '"%fp%"' on '"%fp%"'") relScript relSrc
+  _ <- timeAndExitOnErr' opts ch cmdLabel [constructCmdText] channelOut channelErr (parAwareProc opts) (hledger, args, stdLines)
   return journalOut

src/Hledger/Flow/Common.hs

@@ -9,12 +9,14 @@ module Hledger.Flow.Common
     , showCmdArgs
     , consoleChannelLoop
     , terminateChannelLoop
+    , dummyLogger
     , channelOut, channelOutLn
     , channelErr, channelErrLn
     , errExit
     , logVerbose
-    , timeAndExitOnErr
+    , timeAndExitOnErr, timeAndExitOnErr'
     , parAwareProc
+    , inprocWithErrFun
     , verboseTestFile
     , relativeToBase
     , relativeToBase'
@@ -55,7 +57,7 @@ import qualified Data.Map.Strict as Map
 import Data.Time.LocalTime
 
 import Data.Function (on)
-import qualified Data.List as List (nub, sort, sortBy, groupBy)
+import qualified Data.List as List (nub, null, sort, sortBy, groupBy)
 import Data.Ord (comparing)
 import Hledger.Flow.Types
 import qualified Hledger.Flow.Import.Types as IT
@@ -103,6 +105,9 @@ showCmdArgs args = T.intercalate " " (map escapeArg args)
 escapeArg :: Text -> Text
 escapeArg a = if (T.count " " a > 0) then "'" <> a <> "'" else a
 
+dummyLogger :: TChan LogMessage -> Text -> IO ()
+dummyLogger _ _ = return ()
+
 channelOut :: TChan LogMessage -> Text -> IO ()
 channelOut ch txt = atomically $ writeTChan ch $ StdOut txt
 
@@ -153,42 +158,66 @@ terminateChannelLoop ch = atomically $ writeTChan ch Terminate
 logVerbose :: HasVerbosity o => o -> TChan LogMessage -> Text -> IO ()
 logVerbose opts ch msg = if (verbose opts) then logToChannel ch msg else return ()
 
-logTimedAction :: HasVerbosity o => o -> TChan LogMessage -> Text -> IO FullOutput -> IO FullTimedOutput
-logTimedAction opts ch msg action = do
-  logVerbose opts ch $ format ("Begin: "%s) msg
-  timed@((ec, _, _), diff) <- time action
-  logVerbose opts ch $ format ("End:   "%s%" "%s%" ("%s%")") msg (repr ec) (repr diff)
+descriptiveOutput :: Text -> Text -> Text
+descriptiveOutput outputLabel outTxt = do
+  if not (T.null outTxt)
+    then format (s%":\n"%s%"\n") outputLabel outTxt
+    else ""
+
+logTimedAction :: HasVerbosity o => o -> TChan LogMessage -> Text -> [Text]
+  -> (TChan LogMessage -> Text -> IO ()) -> (TChan LogMessage -> Text -> IO ())
+  -> IO FullOutput
+  -> IO FullTimedOutput
+logTimedAction opts ch cmdLabel extraCmdLabels stdoutLogger stderrLogger action = do
+  logVerbose opts ch $ format ("Begin: "%s) cmdLabel
+  if (List.null extraCmdLabels) then return () else logVerbose opts ch $ T.intercalate "\n" extraCmdLabels
+  timed@((ec, stdOut, stdErr), diff) <- time action
+  stdoutLogger ch stdOut
+  stderrLogger ch stdErr
+  logVerbose opts ch $ format ("End:   "%s%" "%s%" ("%s%")") cmdLabel (repr ec) (repr diff)
   return timed
 
-timeAndExitOnErr :: HasVerbosity o => o -> TChan LogMessage -> Text -> IO FullOutput -> IO FullTimedOutput
-timeAndExitOnErr opts ch msg action = do
-  timed@((ec, stdOut, stdErr), _) <- logTimedAction opts ch msg action
-  if not (T.null stdErr)
-    then channelErr ch stdErr
-    else return ()
+timeAndExitOnErr :: (HasSequential o, HasVerbosity o) => o -> TChan LogMessage -> Text
+  -> (TChan LogMessage -> Text -> IO ()) -> (TChan LogMessage -> Text -> IO ())
+  -> ProcFun -> ProcInput
+  -> IO FullTimedOutput
+timeAndExitOnErr opts ch cmdLabel = timeAndExitOnErr' opts ch cmdLabel []
+
+timeAndExitOnErr' :: (HasSequential o, HasVerbosity o) => o -> TChan LogMessage -> Text -> [Text]
+  -> (TChan LogMessage -> Text -> IO ()) -> (TChan LogMessage -> Text -> IO ())
+  -> ProcFun -> ProcInput
+  -> IO FullTimedOutput
+timeAndExitOnErr' opts ch cmdLabel extraCmdLabels stdoutLogger stderrLogger procFun (cmd, args, stdInput) = do
+  let action = procFun cmd args stdInput
+  timed@((ec, stdOut, stdErr), _) <- logTimedAction opts ch cmdLabel extraCmdLabels stdoutLogger stderrLogger action
   case ec of
     ExitFailure i -> do
-      let msgOut = if not (T.null stdOut)
-            then format ("Standard output:\n"%s%"\n") stdOut
-            else ""
-
-      let msgErr = if not (T.null stdErr)
-            then format ("Error output:\n"%s%"\n") stdErr
-            else ""
+      let cmdText = format (s%" "%s) cmd $ showCmdArgs args
+      let msgOut = descriptiveOutput "Standard output" stdOut
+      let msgErr = descriptiveOutput "Error output" stdErr
 
-      let exitMsg = format ("\nhledger-flow: an external process exited with exit code "%d%". \n"
-                            %s%s%"\nSee verbose output for more details.") i msgOut msgErr
+      let exitMsg = format ("\n=== Begin Error: "%s%" ===\nExternal command:\n"%s%"\nExit code "%d%"\n"
+                            %s%s%"=== End Error: "%s%" ===\n") cmdLabel cmdText i msgOut msgErr cmdLabel
       errExit i ch exitMsg timed
     ExitSuccess -> return timed
 
-procWithEmptyOutput :: MonadIO io => Text -> [Text] -> Shell Line -> io FullOutput
+procWithEmptyOutput :: ProcFun
 procWithEmptyOutput cmd args stdinput = do
   ec <- proc cmd args stdinput
   return (ec, T.empty, T.empty)
 
-parAwareProc :: (HasSequential o, MonadIO io) => o -> Text -> [Text] -> Shell Line -> io FullOutput
+parAwareProc :: HasSequential o => o -> ProcFun
 parAwareProc opts = if (sequential opts) then procWithEmptyOutput else procStrictWithErr
 
+inprocWithErrFun :: (Text -> IO ()) -> ProcInput -> Shell Line
+inprocWithErrFun errFun (cmd, args, standardInput) = do
+  result <- inprocWithErr cmd args standardInput
+  case result of
+    Right ln -> return ln
+    Left  ln -> do
+      (liftIO . errFun . lineToText) ln
+      empty
+
 verboseTestFile :: (HasVerbosity o, HasBaseDir o) => o -> TChan LogMessage -> FilePath -> IO Bool
 verboseTestFile opts ch p = do
   fileExists <- testfile p

src/Hledger/Flow/Reports.hs

@@ -60,11 +60,10 @@ generateReport' opts ch journal outputFile args = do
   let reportArgs = ["--file", format fp journal] ++ args
   let reportDisplayArgs = ["--file", format fp relativeJournal] ++ args
   let hledger = format fp $ FlowTypes.hlPath . hledgerInfo $ opts :: Text
-  let action = procStrictWithErr hledger reportArgs empty
-  let cmd = format ("hledger "%s) $ showCmdArgs reportDisplayArgs
-  result@((exitCode, stdOut, _), _) <- timeAndExitOnErr opts ch cmd action
+  let cmdLabel = format ("hledger "%s) $ showCmdArgs reportDisplayArgs
+  result@((exitCode, stdOut, _), _) <- timeAndExitOnErr opts ch cmdLabel dummyLogger channelErr procStrictWithErr (hledger, reportArgs, empty)
   if not (T.null stdOut) then do
-    writeTextFile outputFile (cmd <> "\n\n"<> stdOut)
+    writeTextFile outputFile (cmdLabel <> "\n\n"<> stdOut)
     channelOutLn ch $ format ("Wrote "%fp) $ relativeToBase opts outputFile
-    else channelErrLn ch $ format ("No report output for '"%s%"' "%s) cmd (repr exitCode)
+    else channelErrLn ch $ format ("No report output for '"%s%"' "%s) cmdLabel (repr exitCode)
   return (outputFile, result)

src/Hledger/Flow/Types.hs

@@ -11,6 +11,9 @@ data LogMessage = StdOut Text | StdErr Text | Terminate deriving (Show)
 type FullOutput = (ExitCode, Text, Text)
 type FullTimedOutput = (FullOutput, NominalDiffTime)
 
+type ProcFun = Text -> [Text] -> Shell Line -> IO FullOutput
+type ProcInput = (Text, [Text], Shell Line)
+
 data HledgerInfo = HledgerInfo { hlPath :: FilePath
                                , hlVersion :: Text
                                }