hledger-flow 0.11.1.1 → 0.11.1.2
raw patch · 10 files changed
+180/−84 lines, 10 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Hledger.Flow.Common: logVerboseTime :: (HasVerbosity o, HasExitCode a) => o -> TChan LogMessage -> Text -> IO a -> IO (a, NominalDiffTime)
- Hledger.Flow.Types: class HasExitCode a
- Hledger.Flow.Types: exitCode :: HasExitCode a => a -> ExitCode
- Hledger.Flow.Types: instance Hledger.Flow.Types.HasExitCode GHC.IO.Exception.ExitCode
- Hledger.Flow.Types: instance Hledger.Flow.Types.HasExitCode Hledger.Flow.Types.FullOutput
+ Hledger.Flow.Common: channelErrLn :: TChan LogMessage -> Text -> IO ()
+ Hledger.Flow.Common: channelOutLn :: TChan LogMessage -> Text -> IO ()
+ Hledger.Flow.Common: hledgerInfoFromPath :: Maybe FilePath -> IO HledgerInfo
+ Hledger.Flow.Common: hledgerPathFromOption :: Maybe FilePath -> IO FilePath
+ Hledger.Flow.Common: hledgerVersionFromPath :: FilePath -> IO Text
+ Hledger.Flow.Common: parAwareProc :: (HasSequential o, MonadIO io) => o -> Text -> [Text] -> Shell Line -> io FullOutput
+ Hledger.Flow.Common: timeAndExitOnErr :: HasVerbosity o => o -> TChan LogMessage -> Text -> IO FullOutput -> IO FullTimedOutput
+ Hledger.Flow.Import.Types: [hledgerInfo] :: ImportOptions -> HledgerInfo
+ Hledger.Flow.Import.Types: instance Hledger.Flow.Types.HasSequential Hledger.Flow.Import.Types.ImportOptions
+ Hledger.Flow.Report.Types: [hledgerInfo] :: ReportOptions -> HledgerInfo
+ Hledger.Flow.Report.Types: instance Hledger.Flow.Types.HasSequential Hledger.Flow.Report.Types.ReportOptions
+ Hledger.Flow.Types: HledgerInfo :: FilePath -> Text -> HledgerInfo
+ Hledger.Flow.Types: [hlPath] :: HledgerInfo -> FilePath
+ Hledger.Flow.Types: [hlVersion] :: HledgerInfo -> Text
+ Hledger.Flow.Types: class HasSequential a
+ Hledger.Flow.Types: data HledgerInfo
+ Hledger.Flow.Types: instance GHC.Show.Show Hledger.Flow.Types.HledgerInfo
+ Hledger.Flow.Types: sequential :: HasSequential a => a -> Bool
- Hledger.Flow.Import.Types: ImportOptions :: FilePath -> Bool -> Bool -> Bool -> ImportOptions
+ Hledger.Flow.Import.Types: ImportOptions :: FilePath -> HledgerInfo -> Bool -> Bool -> Bool -> ImportOptions
- Hledger.Flow.Report.Types: ReportOptions :: FilePath -> Bool -> Bool -> Bool -> ReportOptions
+ Hledger.Flow.Report.Types: ReportOptions :: FilePath -> HledgerInfo -> Bool -> Bool -> Bool -> ReportOptions
Files
- ChangeLog.md +7/−0
- app/Main.hs +23/−12
- hledger-flow.cabal +2/−2
- src/Hledger/Flow/CSVImport.hs +25/−21
- src/Hledger/Flow/Common.hs +82/−13
- src/Hledger/Flow/Import/Types.hs +6/−2
- src/Hledger/Flow/Report/Types.hs +8/−3
- src/Hledger/Flow/Reports.hs +15/−17
- src/Hledger/Flow/Types.hs +7/−8
- test/TestHelpers.hs +5/−6
ChangeLog.md view
@@ -1,5 +1,12 @@ # Changelog for [hledger-flow](https://github.com/apauley/hledger-flow) +## 0.11.1.2++- Exit with an error code when any external script fails - https://github.com/apauley/hledger-flow/issues/28+- Capture external process output when doing parallel processing, in order to better prevent mangled concurrent output.+- Allow users to specify a path to an hledger executable+- Display a user-friendly error message if hledger cannot be found - https://github.com/apauley/hledger-flow/issues/22+ ## 0.11.1.1 - Support input files from the year 2011 - https://github.com/apauley/hledger-flow/issues/27
app/Main.hs view
@@ -14,7 +14,13 @@ import Hledger.Flow.Reports import Hledger.Flow.CSVImport -type SubcommandParams = (Maybe FilePath, Bool, Bool, Bool)+data SubcommandParams = SubcommandParams { maybeBaseDir :: Maybe FilePath+ , hledgerPathOpt :: Maybe FilePath+ , verbose :: Bool+ , showOpts :: Bool+ , sequential :: Bool+ }+ deriving (Show) data Command = Version (Maybe Text) | Import SubcommandParams | Report SubcommandParams deriving (Show) main :: IO ()@@ -26,20 +32,24 @@ Report subParams -> toReportOptions subParams >>= generateReports toImportOptions :: SubcommandParams -> IO IT.ImportOptions-toImportOptions (maybeBaseDir, verbose, showOpts, sequential) = do- bd <- dirOrPwd maybeBaseDir+toImportOptions params = do+ bd <- dirOrPwd $ maybeBaseDir params+ hli <- hledgerInfoFromPath $ hledgerPathOpt params return IT.ImportOptions { IT.baseDir = bd- , IT.verbose = verbose- , IT.showOptions = showOpts- , IT.sequential = sequential }+ , IT.hledgerInfo = hli+ , IT.verbose = verbose params+ , IT.showOptions = showOpts params+ , IT.sequential = sequential params } toReportOptions :: SubcommandParams -> IO RT.ReportOptions-toReportOptions (maybeBaseDir, verbose, showOpts, sequential) = do- bd <- dirOrPwd maybeBaseDir+toReportOptions params = do+ bd <- dirOrPwd $ maybeBaseDir params+ hli <- hledgerInfoFromPath $ hledgerPathOpt params return RT.ReportOptions { RT.baseDir = bd- , RT.verbose = verbose- , RT.showOptions = showOpts- , RT.sequential = sequential }+ , RT.hledgerInfo = hli+ , RT.verbose = verbose params+ , RT.showOptions = showOpts params+ , RT.sequential = sequential params } parser :: Parser Command parser = fmap Import (subcommand "import" "Converts CSV transactions into categorised journal files" subcommandParser)@@ -47,8 +57,9 @@ <|> fmap Version (subcommand "version" "Display version information" noArgs) subcommandParser :: Parser SubcommandParams-subcommandParser = (,,,)+subcommandParser = SubcommandParams <$> optional (argPath "basedir" "The hledger-flow base directory")+ <*> optional (optPath "hledger-path" 'H' "The full path to an hledger executable") <*> switch (long "verbose" <> short 'v' <> help "Print more verbose output") <*> switch (long "show-options" <> help "Print the options this program will run with") <*> switch (long "sequential" <> help "Disable parallel processing")
hledger-flow.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: f8d8a671bb403b7d049e7310c834a0396e836ca37eb0c7717ccb48a15691213d+-- hash: 752e52ff23c6e0069c279dc21baa46e6c8b0b20124b506e7bdca5d52136bb483 name: hledger-flow-version: 0.11.1.1+version: 0.11.1.2 synopsis: An hledger workflow focusing on automated statement import and classification. description: Please see the README on GitHub at <https://github.com/apauley/hledger-flow#readme> category: Finance, Console
src/Hledger/Flow/CSVImport.hs view
@@ -4,11 +4,11 @@ ( importCSVs ) where -import Turtle+import Turtle hiding (stdout, stderr, proc, procStrictWithErr) import Prelude hiding (FilePath, putStrLn, take) import qualified Data.Text as T import qualified Data.List.NonEmpty as NonEmpty-import Hledger.Flow.Types (LogMessage)+import qualified Hledger.Flow.Types as FlowTypes import Hledger.Flow.Import.Types import Hledger.Flow.Common import Control.Concurrent.STM@@ -18,10 +18,10 @@ do ch <- liftIO newTChanIO logHandle <- fork $ consoleChannelLoop ch- liftIO $ if (showOptions opts) then channelOut ch (repr opts) else return ()+ liftIO $ if (showOptions opts) then channelOutLn ch (repr opts) else return () liftIO $ logVerbose opts ch "Starting import" (journals, diff) <- time $ liftIO $ importCSVs' opts ch- liftIO $ channelOut ch $ format ("Imported "%d%" journals in "%s) (length journals) $ repr diff+ liftIO $ channelOutLn ch $ format ("Imported "%d%" journals in "%s) (length journals) $ repr diff liftIO $ terminateChannelLoop ch wait logHandle )@@ -32,9 +32,9 @@ inputFilePattern :: Pattern Text inputFilePattern = contains (once (oneOf pathSeparators) <> asciiCI "1-in" <> once (oneOf pathSeparators) <> plus digit <> once (oneOf pathSeparators)) -importCSVs' :: ImportOptions -> TChan LogMessage -> IO [FilePath]+importCSVs' :: ImportOptions -> TChan FlowTypes.LogMessage -> IO [FilePath] importCSVs' opts ch = do- channelOut ch "Collecting input files..."+ channelOutLn ch "Collecting input files..." (inputFiles, diff) <- time $ single . shellToList . onlyFiles $ find inputFilePattern $ baseDir opts let fileCount = length inputFiles if (fileCount == 0) then@@ -45,20 +45,20 @@ errExit 1 ch msg [] else do- channelOut ch $ format ("Found "%d%" input files in "%s%". Proceeding with import...") fileCount (repr diff)+ channelOutLn ch $ format ("Found "%d%" input files in "%s%". Proceeding with import...") fileCount (repr diff) let actions = map (extractAndImport opts ch) inputFiles :: [IO FilePath] importedJournals <- if (sequential opts) then sequence actions else single . shellToList $ parallel actions sh $ writeIncludesUpTo opts ch "import" importedJournals return importedJournals -extractAndImport :: ImportOptions -> TChan LogMessage -> FilePath -> IO FilePath+extractAndImport :: ImportOptions -> TChan FlowTypes.LogMessage -> FilePath -> IO FilePath extractAndImport opts ch inputFile = do case extractImportDirs inputFile of Right importDirs -> importCSV opts ch importDirs inputFile Left errorMessage -> do errExit 1 ch errorMessage inputFile -importCSV :: ImportOptions -> TChan LogMessage -> ImportDirs -> FilePath -> IO FilePath+importCSV :: ImportOptions -> TChan FlowTypes.LogMessage -> ImportDirs -> FilePath -> IO FilePath importCSV opts ch importDirs srcFile = do let preprocessScript = accountDir importDirs </> "preprocess" let constructScript = accountDir importDirs </> "construct"@@ -74,33 +74,34 @@ mktree $ directory journalOut importFun csvFile journalOut -preprocessIfNeeded :: ImportOptions -> TChan LogMessage -> FilePath -> Line -> Line -> Line -> FilePath -> IO FilePath+preprocessIfNeeded :: ImportOptions -> TChan FlowTypes.LogMessage -> FilePath -> Line -> Line -> Line -> FilePath -> IO FilePath preprocessIfNeeded opts ch script bank account owner src = do shouldPreprocess <- verboseTestFile opts ch script if shouldPreprocess then preprocess opts ch script bank account owner src else return src -preprocess :: ImportOptions -> TChan LogMessage -> FilePath -> Line -> Line -> Line -> FilePath -> IO FilePath+preprocess :: ImportOptions -> TChan FlowTypes.LogMessage -> FilePath -> Line -> Line -> Line -> FilePath -> IO FilePath 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 = proc script' [format fp src, format fp csvOut, lineToText bank, lineToText account, lineToText owner] empty+ let action = (parAwareProc opts) script' [format fp src, format fp csvOut, lineToText bank, lineToText account, lineToText owner] empty let relScript = relativeToBase opts script let relSrc = relativeToBase opts src let msg = format ("executing '"%fp%"' on '"%fp%"'") relScript relSrc- _ <- logVerboseTime opts ch msg action+ ((_, stdOut, _), _) <- timeAndExitOnErr opts ch msg action+ channelOut ch stdOut return csvOut -hledgerImport :: ImportOptions -> TChan LogMessage -> FilePath -> FilePath -> IO FilePath+hledgerImport :: ImportOptions -> TChan FlowTypes.LogMessage -> FilePath -> FilePath -> IO FilePath hledgerImport opts ch csvSrc journalOut = do case extractImportDirs csvSrc of Right importDirs -> hledgerImport' opts ch importDirs csvSrc journalOut Left errorMessage -> do errExit 1 ch errorMessage csvSrc -hledgerImport' :: ImportOptions -> TChan LogMessage -> ImportDirs -> FilePath -> FilePath -> IO FilePath+hledgerImport' :: ImportOptions -> TChan FlowTypes.LogMessage -> ImportDirs -> FilePath -> FilePath -> IO FilePath hledgerImport' opts ch importDirs csvSrc journalOut = do let candidates = rulesFileCandidates csvSrc importDirs maybeRulesFile <- firstExistingFile candidates@@ -108,9 +109,11 @@ case maybeRulesFile of Just rf -> do let relRules = relativeToBase opts rf- let action = proc "hledger" ["print", "--rules-file", format fp rf, "--file", format fp csvSrc, "--output-file", format fp journalOut] empty+ 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- _ <- logVerboseTime opts ch msg action+ ((_, stdOut, _), _) <- timeAndExitOnErr opts ch msg action+ channelOut ch stdOut return journalOut Nothing -> do@@ -151,14 +154,15 @@ map (</> srcSpecificFilename) [accountDir importDirs, bankDir importDirs, importDir importDirs] else [] -customConstruct :: ImportOptions -> TChan LogMessage -> FilePath -> Line -> Line -> Line -> FilePath -> FilePath -> IO FilePath+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 action = proc "hledger" ["print", "--ignore-assertions", "--file", "-", "--output-file", format fp journalOut] importOut+ 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 relSrc = relativeToBase opts csvSrc let msg = format ("executing '"%fp%"' on '"%fp%"'") relScript relSrc- _ <- logVerboseTime opts ch msg action-+ ((_, stdOut, _), _) <- timeAndExitOnErr opts ch msg action+ channelOut ch stdOut return journalOut
src/Hledger/Flow/Common.hs view
@@ -3,14 +3,18 @@ module Hledger.Flow.Common ( docURL , versionInfo+ , hledgerPathFromOption+ , hledgerVersionFromPath+ , hledgerInfoFromPath , showCmdArgs , consoleChannelLoop , terminateChannelLoop- , channelOut- , channelErr+ , channelOut, channelOutLn+ , channelErr, channelErrLn , errExit , logVerbose- , logVerboseTime+ , timeAndExitOnErr+ , parAwareProc , verboseTestFile , relativeToBase , relativeToBase'@@ -66,6 +70,33 @@ versionInfo :: NE.NonEmpty Line versionInfo = textToLines $ T.pack ("hledger-flow " ++ Version.showVersion version) +hledgerPathFromOption :: Maybe FilePath -> IO FilePath+hledgerPathFromOption pathOption = do+ case pathOption of+ Just h -> do+ isOnDisk <- testfile h+ if isOnDisk then return h else do+ let msg = format ("Unable to find hledger at "%fp) h+ errExit' 1 (T.hPutStrLn H.stderr) msg h+ Nothing -> do+ maybeH <- which "hledger"+ case maybeH of+ Just h -> return h+ Nothing -> do+ let msg = "Unable to find hledger in your path.\n"+ <> "You need to either install hledger, or add it to your PATH, or provide the path to an hledger executable.\n\n"+ <> "There are a number of installation options on the hledger website: https://hledger.org/download.html"+ errExit' 1 (T.hPutStrLn H.stderr) msg "/"++hledgerVersionFromPath :: FilePath -> IO Text+hledgerVersionFromPath hlp = fmap (T.strip . linesToText) (single $ shellToList $ inproc (format fp hlp) ["--version"] empty)++hledgerInfoFromPath :: Maybe FilePath -> IO HledgerInfo+hledgerInfoFromPath pathOption = do+ hlp <- hledgerPathFromOption pathOption+ hlv <- hledgerVersionFromPath hlp+ return $ HledgerInfo hlp hlv+ showCmdArgs :: [Text] -> Text showCmdArgs args = T.intercalate " " (map escapeArg args) @@ -75,12 +106,21 @@ channelOut :: TChan LogMessage -> Text -> IO () channelOut ch txt = atomically $ writeTChan ch $ StdOut txt +channelOutLn :: TChan LogMessage -> Text -> IO ()+channelOutLn ch txt = channelOut ch (txt <> "\n")+ channelErr :: TChan LogMessage -> Text -> IO () channelErr ch txt = atomically $ writeTChan ch $ StdErr txt +channelErrLn :: TChan LogMessage -> Text -> IO ()+channelErrLn ch txt = channelErr ch (txt <> "\n")+ errExit :: Int -> TChan LogMessage -> Text -> a -> IO a-errExit exitStatus ch errorMessage dummyReturnValue = do- channelErr ch errorMessage+errExit exitStatus ch = errExit' exitStatus (channelErrLn ch)++errExit' :: Int -> (Text -> IO ()) -> Text -> a -> IO a+errExit' exitStatus logFun errorMessage dummyReturnValue = do+ logFun errorMessage sleep 0.1 _ <- exit $ ExitFailure exitStatus return dummyReturnValue@@ -93,17 +133,17 @@ logToChannel :: TChan LogMessage -> Text -> IO () logToChannel ch msg = do ts <- timestampPrefix msg- channelErr ch ts+ channelErrLn ch ts consoleChannelLoop :: TChan LogMessage -> IO () consoleChannelLoop ch = do logMsg <- atomically $ readTChan ch case logMsg of StdOut msg -> do- T.hPutStrLn H.stdout msg+ T.hPutStr H.stdout msg consoleChannelLoop ch StdErr msg -> do- T.hPutStrLn H.stderr msg+ T.hPutStr H.stderr msg consoleChannelLoop ch Terminate -> return () @@ -113,12 +153,41 @@ logVerbose :: HasVerbosity o => o -> TChan LogMessage -> Text -> IO () logVerbose opts ch msg = if (verbose opts) then logToChannel ch msg else return () -logVerboseTime :: (HasVerbosity o, HasExitCode a) => o -> TChan LogMessage -> Text -> IO a -> IO (a, NominalDiffTime)-logVerboseTime opts ch msg action = do+logTimedAction :: HasVerbosity o => o -> TChan LogMessage -> Text -> IO FullOutput -> IO FullTimedOutput+logTimedAction opts ch msg action = do logVerbose opts ch $ format ("Begin: "%s) msg- (result, diff) <- time action- logVerbose opts ch $ format ("End: "%s%" "%s%" ("%s%")") msg (repr $ exitCode result) (repr diff)- return (result, diff)+ timed@((ec, _, _), diff) <- time action+ logVerbose opts ch $ format ("End: "%s%" "%s%" ("%s%")") msg (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 ()+ 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 exitMsg = format ("\nhledger-flow: an external process exited with exit code "%d%". \n"+ %s%s%"\nSee verbose output for more details.") i msgOut msgErr+ errExit i ch exitMsg timed+ ExitSuccess -> return timed++procWithEmptyOutput :: MonadIO io => Text -> [Text] -> Shell Line -> io FullOutput+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 opts = if (sequential opts) then procWithEmptyOutput else procStrictWithErr verboseTestFile :: (HasVerbosity o, HasBaseDir o) => o -> TChan LogMessage -> FilePath -> IO Bool verboseTestFile opts ch p = do
src/Hledger/Flow/Import/Types.hs view
@@ -6,16 +6,20 @@ import Hledger.Flow.Types data ImportOptions = ImportOptions { baseDir :: FilePath+ , hledgerInfo :: HledgerInfo , verbose :: Bool , showOptions :: Bool , sequential :: Bool } deriving (Show) instance HasVerbosity ImportOptions where- verbose (ImportOptions _ v _ _) = v+ verbose (ImportOptions _ _ v _ _) = v +instance HasSequential ImportOptions where+ sequential (ImportOptions _ _ _ _ sq) = sq+ instance HasBaseDir ImportOptions where- baseDir (ImportOptions bd _ _ _) = bd+ baseDir (ImportOptions bd _ _ _ _) = bd data ImportDirs = ImportDirs { importDir :: FilePath , ownerDir :: FilePath
src/Hledger/Flow/Report/Types.hs view
@@ -6,13 +6,18 @@ import Hledger.Flow.Types data ReportOptions = ReportOptions { baseDir :: FilePath+ , hledgerInfo :: HledgerInfo , verbose :: Bool , showOptions :: Bool- , sequential :: Bool }+ , sequential :: Bool+ } deriving (Show) instance HasVerbosity ReportOptions where- verbose (ReportOptions _ v _ _) = v+ verbose (ReportOptions _ _ v _ _) = v +instance HasSequential ReportOptions where+ sequential (ReportOptions _ _ _ _ sq) = sq+ instance HasBaseDir ReportOptions where- baseDir (ReportOptions bd _ _ _) = bd+ baseDir (ReportOptions bd _ _ _ _) = bd
src/Hledger/Flow/Reports.hs view
@@ -4,10 +4,10 @@ ( generateReports ) where -import Turtle+import Turtle hiding (stdout, stderr, proc) import Prelude hiding (FilePath, putStrLn, writeFile) import qualified Data.Text as T-import Hledger.Flow.Types (LogMessage, FullTimedOutput)+import qualified Hledger.Flow.Types as FlowTypes import Hledger.Flow.Report.Types import Hledger.Flow.Common import Control.Concurrent.STM@@ -17,20 +17,20 @@ do ch <- liftIO newTChanIO logHandle <- fork $ consoleChannelLoop ch- liftIO $ if (showOptions opts) then channelOut ch (repr opts) else return ()+ liftIO $ if (showOptions opts) then channelOutLn ch (repr opts) else return () (reports, diff) <- time $ liftIO $ generateReports' opts ch- liftIO $ channelOut ch $ format ("Generated "%d%" reports in "%s) (length reports) $ repr diff+ liftIO $ channelOutLn ch $ format ("Generated "%d%" reports in "%s) (length reports) $ repr diff liftIO $ terminateChannelLoop ch wait logHandle ) -generateReports' :: ReportOptions -> TChan LogMessage -> IO [FilePath]+generateReports' :: ReportOptions -> TChan FlowTypes.LogMessage -> IO [FilePath] generateReports' opts ch = do logVerbose opts ch "Something will be here Real Soon Now (tm)"- channelOut ch "Report generation has not been implemented. Yet. https://github.com/apauley/hledger-flow/pull/4"+ channelOutLn ch "Report generation has not been implemented. Yet. https://github.com/apauley/hledger-flow/pull/4" ownerReports opts ch "everyone" -ownerReports :: ReportOptions -> TChan LogMessage -> Text -> IO [FilePath]+ownerReports :: ReportOptions -> TChan FlowTypes.LogMessage -> Text -> IO [FilePath] ownerReports opts ch owner = do let journal = (baseDir opts) </> "all-years" <.> "journal" let reportsDir = (baseDir opts) </> "reports" </> fromText owner@@ -38,7 +38,7 @@ results <- if (sequential opts) then sequence actions else single $ shellToList $ parallel actions return $ map fst results -incomeStatement :: ReportOptions -> TChan LogMessage -> FilePath -> FilePath -> IO (FilePath, FullTimedOutput)+incomeStatement :: ReportOptions -> TChan FlowTypes.LogMessage -> FilePath -> FilePath -> IO (FilePath, FlowTypes.FullTimedOutput) incomeStatement opts ch journal reportsDir = do mktree reportsDir let outputFile = reportsDir </> "income-expenses" <.> "txt"@@ -46,27 +46,25 @@ let reportArgs = ["incomestatement"] ++ sharedOptions ++ ["--average", "--yearly"] generateReport' opts ch journal outputFile reportArgs -accountList :: ReportOptions -> TChan LogMessage -> FilePath -> FilePath -> IO (FilePath, FullTimedOutput)+accountList :: ReportOptions -> TChan FlowTypes.LogMessage -> FilePath -> FilePath -> IO (FilePath, FlowTypes.FullTimedOutput) accountList opts ch journal reportsDir = do let outputFile = reportsDir </> "accounts" <.> "txt" let reportArgs = ["accounts"] generateReport' opts ch journal outputFile reportArgs -generateReport' :: ReportOptions -> TChan LogMessage -> FilePath -> FilePath -> [Text] -> IO (FilePath, FullTimedOutput)+generateReport' :: ReportOptions -> TChan FlowTypes.LogMessage -> FilePath -> FilePath -> [Text] -> IO (FilePath, FlowTypes.FullTimedOutput) generateReport' opts ch journal outputFile args = do let reportsDir = directory outputFile mktree reportsDir let relativeJournal = relativeToBase opts journal let reportArgs = ["--file", format fp journal] ++ args let reportDisplayArgs = ["--file", format fp relativeJournal] ++ args- let action = procStrictWithErr "hledger" reportArgs empty+ 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, stdErr), _) <- logVerboseTime opts ch cmd action+ result@((exitCode, stdOut, _), _) <- timeAndExitOnErr opts ch cmd action if not (T.null stdOut) then do writeTextFile outputFile (cmd <> "\n\n"<> stdOut)- channelOut ch $ format ("Wrote "%fp) $ relativeToBase opts outputFile- else channelErr ch $ format ("No report output for '"%s%"' "%s) cmd (repr exitCode)- if not (T.null stdErr)- then channelErr ch $ stdErr- else return ()+ channelOutLn ch $ format ("Wrote "%fp) $ relativeToBase opts outputFile+ else channelErrLn ch $ format ("No report output for '"%s%"' "%s) cmd (repr exitCode) return (outputFile, result)
src/Hledger/Flow/Types.hs view
@@ -11,17 +11,16 @@ type FullOutput = (ExitCode, Text, Text) type FullTimedOutput = (FullOutput, NominalDiffTime) +data HledgerInfo = HledgerInfo { hlPath :: FilePath+ , hlVersion :: Text+ }+ deriving (Show)+ class HasVerbosity a where verbose :: a -> Bool class HasBaseDir a where baseDir :: a -> FilePath -class HasExitCode a where- exitCode :: a -> ExitCode--instance HasExitCode ExitCode where- exitCode c = c--instance HasExitCode FullOutput where- exitCode (c, _, _) = c+class HasSequential a where+ sequential :: a -> Bool
test/TestHelpers.hs view
@@ -3,14 +3,10 @@ module TestHelpers where -import Test.HUnit import Turtle import Prelude hiding (FilePath)-import qualified Data.Map.Strict as Map-import qualified Control.Foldl as Fold-import qualified Data.Text as T-import qualified Data.List as List (sort) +import qualified Hledger.Flow.Types as FlowTypes import Hledger.Flow.Import.Types import Hledger.Flow.Common @@ -49,8 +45,11 @@ extraFiles = ["import/john/bogartbank/savings/2017-opening.journal"] :: [FilePath] hiddenFiles = [".hiddenfile", "checking/.DS_Store", "import/john/bogartbank/savings/1-in/.anotherhiddenfile", "import/john/bogartbank/checking/1-in/2018/.hidden"] :: [FilePath] +defaultHlInfo :: FlowTypes.HledgerInfo+defaultHlInfo = FlowTypes.HledgerInfo "/path/to/hledger" "1.2.3"+ defaultOpts :: FilePath -> ImportOptions-defaultOpts bd = ImportOptions bd False False False+defaultOpts bd = ImportOptions bd defaultHlInfo False False False toJournals :: [FilePath] -> [FilePath] toJournals = map (changePathAndExtension "3-journal" "journal")