From 603b2e9f0981532b10e76ba24408c41da6712f04 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Sat, 12 Mar 2022 21:16:33 +1100 Subject: [PATCH] ref: Use ExceptT String IO a instead of IO (Either String a). This increases composability and avoids some ugly case handling. We re-export runExceptT in Hledger.Read. The final return types of the following functions has been changed from IO (Either String a) to ExceptT String IO a. If this causes a problem, you can get the old behaviour by calling runExceptT on the output: readJournal, readJournalFiles, readJournalFile Or, you can use the easy functions readJournal', readJournalFiles', and readJournalFile', which assume default options and return in the IO monad. --- bin/hledger-check-fancyassertions.hs | 3 +- hledger-lib/Hledger/Read.hs | 126 +++++++------ hledger-lib/Hledger/Read/CsvReader.hs | 200 ++++++++++----------- hledger-ui/Hledger/UI/ErrorScreen.hs | 14 +- hledger-ui/Hledger/UI/TransactionScreen.hs | 4 +- hledger-ui/hledger-ui.cabal | 3 +- hledger-ui/package.yaml | 1 + hledger-web/Hledger/Web/Foundation.hs | 19 +- hledger-web/Hledger/Web/Handler/EditR.hs | 3 +- hledger-web/Hledger/Web/Handler/UploadR.hs | 3 +- hledger-web/Hledger/Web/Test.hs | 1 - hledger-web/Hledger/Web/Widget/Common.hs | 13 +- hledger/Hledger/Cli/Commands.hs | 10 +- hledger/Hledger/Cli/Commands/Diff.hs | 4 +- hledger/Hledger/Cli/Commands/Import.hs | 3 +- hledger/Hledger/Cli/Utils.hs | 28 +-- hledger/test/csv.test | 15 +- 17 files changed, 229 insertions(+), 221 deletions(-) diff --git a/bin/hledger-check-fancyassertions.hs b/bin/hledger-check-fancyassertions.hs index ef7ff1feb..44b20e547 100755 --- a/bin/hledger-check-fancyassertions.hs +++ b/bin/hledger-check-fancyassertions.hs @@ -98,6 +98,7 @@ module Main where import Control.Arrow (first) import Control.Monad (mplus, mzero, unless, void) +import Control.Monad.Except (runExceptT) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict (runStateT) import Data.String (fromString) @@ -167,7 +168,7 @@ main :: IO () main = do opts <- execParser args journalFile <- maybe H.defaultJournalPath pure (file opts) - ejournal <- H.readJournalFile (set H.ignore_assertions (ignoreAssertions opts) H.definputopts) journalFile + ejournal <- runExceptT $ H.readJournalFile (set H.ignore_assertions (ignoreAssertions opts) H.definputopts) journalFile case ejournal of Right j -> do (journal, starting) <- fixupJournal opts j diff --git a/hledger-lib/Hledger/Read.hs b/hledger-lib/Hledger/Read.hs index c7d0b46fd..141ed3ce0 100644 --- a/hledger-lib/Hledger/Read.hs +++ b/hledger-lib/Hledger/Read.hs @@ -22,14 +22,20 @@ module Hledger.Read ( PrefixedFilePath, defaultJournal, defaultJournalPath, - readJournalFiles, - readJournalFile, requireJournalFileExists, ensureJournalFileExists, -- * Journal parsing readJournal, + readJournalFile, + readJournalFiles, + runExceptT, + + -- * Easy journal parsing readJournal', + readJournalFile', + readJournalFiles', + orDieTrying, -- * Re-exported JournalReader.tmpostingrulep, @@ -45,10 +51,9 @@ module Hledger.Read ( ) where --- ** imports -import Control.Arrow (right) import qualified Control.Exception as C import Control.Monad (unless, when) -import "mtl" Control.Monad.Except (runExceptT) +import "mtl" Control.Monad.Except (ExceptT(..), runExceptT, liftIO) import Data.Default (def) import Data.Foldable (asum) import Data.List (group, sort, sortBy) @@ -89,36 +94,9 @@ journalEnvVar = "LEDGER_FILE" journalEnvVar2 = "LEDGER" journalDefaultFilename = ".hledger.journal" --- | Read a Journal from the given text, assuming journal format; or --- throw an error. -readJournal' :: Text -> IO Journal -readJournal' t = readJournal definputopts Nothing t >>= either error' return -- PARTIAL: - --- | @readJournal iopts mfile txt@ --- --- Read a Journal from some text, or return an error message. --- --- The reader (data format) is chosen based on, in this order: --- --- - a reader name provided in @iopts@ --- --- - a reader prefix in the @mfile@ path --- --- - a file extension in @mfile@ --- --- If none of these is available, or if the reader name is unrecognised, --- we use the journal reader. (We used to try all readers in this case; --- since hledger 1.17, we prefer predictability.) -readJournal :: InputOpts -> Maybe FilePath -> Text -> IO (Either String Journal) -readJournal iopts mpath txt = do - let r :: Reader IO = - fromMaybe JournalReader.reader $ findReader (mformat_ iopts) mpath - dbg6IO "trying reader" (rFormat r) - (runExceptT . (rReadFn r) iopts (fromMaybe "(string)" mpath)) txt - -- | Read the default journal file specified by the environment, or raise an error. defaultJournal :: IO Journal -defaultJournal = defaultJournalPath >>= readJournalFile definputopts >>= either error' return -- PARTIAL: +defaultJournal = defaultJournalPath >>= runExceptT . readJournalFile definputopts >>= either error' return -- PARTIAL: -- | Get the default journal file path specified by the environment. -- Like ledger, we look first for the LEDGER_FILE environment @@ -144,17 +122,27 @@ defaultJournalPath = do -- (journal:, csv:, timedot:, etc.). type PrefixedFilePath = FilePath --- | Read a Journal from each specified file path and combine them into one. --- Or, return the first error message. +-- | @readJournal iopts mfile txt@ -- --- Combining Journals means concatenating them, basically. --- The parse state resets at the start of each file, which means that --- directives & aliases do not affect subsequent sibling or parent files. --- They do affect included child files though. --- Also the final parse state saved in the Journal does span all files. -readJournalFiles :: InputOpts -> [PrefixedFilePath] -> IO (Either String Journal) -readJournalFiles iopts = - fmap (right (maybe def sconcat . nonEmpty) . sequence) . mapM (readJournalFile iopts) +-- Read a Journal from some text, or return an error message. +-- +-- The reader (data format) is chosen based on, in this order: +-- +-- - a reader name provided in @iopts@ +-- +-- - a reader prefix in the @mfile@ path +-- +-- - a file extension in @mfile@ +-- +-- If none of these is available, or if the reader name is unrecognised, +-- we use the journal reader. (We used to try all readers in this case; +-- since hledger 1.17, we prefer predictability.) +readJournal :: InputOpts -> Maybe FilePath -> Text -> ExceptT String IO Journal +readJournal iopts mpath txt = do + let r :: Reader IO = + fromMaybe JournalReader.reader $ findReader (mformat_ iopts) mpath + dbg6IO "trying reader" (rFormat r) + rReadFn r iopts (fromMaybe "(string)" mpath) txt -- | Read a Journal from this file, or from stdin if the file path is -, -- or return an error message. The file path can have a READER: prefix. @@ -167,26 +155,56 @@ readJournalFiles iopts = -- -- The input options can also configure balance assertion checking, automated posting -- generation, a rules file for converting CSV data, etc. -readJournalFile :: InputOpts -> PrefixedFilePath -> IO (Either String Journal) +readJournalFile :: InputOpts -> PrefixedFilePath -> ExceptT String IO Journal readJournalFile iopts prefixedfile = do let (mfmt, f) = splitReaderPrefix prefixedfile iopts' = iopts{mformat_=asum [mfmt, mformat_ iopts]} - requireJournalFileExists f - t <- readFileOrStdinPortably f + liftIO $ requireJournalFileExists f + t <- liftIO $ readFileOrStdinPortably f -- <- T.readFile f -- or without line ending translation, for testing - ej <- readJournal iopts' (Just f) t - case ej of - Left e -> return $ Left e - Right j | new_ iopts -> do - ds <- previousLatestDates f - let (newj, newds) = journalFilterSinceLatestDates ds j - when (new_save_ iopts && not (null newds)) $ saveLatestDates newds f - return $ Right newj - Right j -> return $ Right j + j <- readJournal iopts' (Just f) t + if new_ iopts + then do + ds <- liftIO $ previousLatestDates f + let (newj, newds) = journalFilterSinceLatestDates ds j + when (new_save_ iopts && not (null newds)) . liftIO $ saveLatestDates newds f + return newj + else return j + +-- | Read a Journal from each specified file path and combine them into one. +-- Or, return the first error message. +-- +-- Combining Journals means concatenating them, basically. +-- The parse state resets at the start of each file, which means that +-- directives & aliases do not affect subsequent sibling or parent files. +-- They do affect included child files though. +-- Also the final parse state saved in the Journal does span all files. +readJournalFiles :: InputOpts -> [PrefixedFilePath] -> ExceptT String IO Journal +readJournalFiles iopts = + fmap (maybe def sconcat . nonEmpty) . mapM (readJournalFile iopts) + +-- | An easy version of 'readJournal' which assumes default options, and fails +-- in the IO monad. +readJournal' :: Text -> IO Journal +readJournal' = orDieTrying . readJournal definputopts Nothing + +-- | An easy version of 'readJournalFile' which assumes default options, and fails +-- in the IO monad. +readJournalFile' :: PrefixedFilePath -> IO Journal +readJournalFile' = orDieTrying . readJournalFile definputopts + +-- | An easy version of 'readJournalFiles'' which assumes default options, and fails +-- in the IO monad. +readJournalFiles' :: [PrefixedFilePath] -> IO Journal +readJournalFiles' = orDieTrying . readJournalFiles definputopts --- ** utilities +-- | Extract ExceptT to the IO monad, failing with an error message if necessary. +orDieTrying :: ExceptT String IO a -> IO a +orDieTrying a = either fail return =<< runExceptT a + -- | If the specified journal file does not exist (and is not "-"), -- give a helpful error and quit. requireJournalFileExists :: FilePath -> IO () diff --git a/hledger-lib/Hledger/Read/CsvReader.hs b/hledger-lib/Hledger/Read/CsvReader.hs index 90c6d2b39..37a51f998 100644 --- a/hledger-lib/Hledger/Read/CsvReader.hs +++ b/hledger-lib/Hledger/Read/CsvReader.hs @@ -38,15 +38,15 @@ where --- ** imports import Control.Applicative (liftA2) -import Control.Exception (IOException, handle, throw) import Control.Monad (unless, when) -import Control.Monad.Except (ExceptT, throwError) +import Control.Monad.Except (ExceptT(..), liftEither, throwError) import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State.Strict (StateT, get, modify', evalStateT) import Control.Monad.Trans.Class (lift) import Data.Char (toLower, isDigit, isSpace, isAlphaNum, ord) import Data.Bifunctor (first) +import Data.Functor ((<&>)) import Data.List (elemIndex, foldl', intersperse, mapAccumL, nub, sortBy) import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.MemoUgly (memo) @@ -60,7 +60,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB import Data.Time.Calendar (Day) import Data.Time.Format (parseTimeM, defaultTimeLocale) -import Safe (atMay, headMay, lastMay, readDef, readMay) +import Safe (atMay, headMay, lastMay, readMay) import System.Directory (doesFileExist) import System.FilePath ((), takeDirectory, takeExtension, takeFileName) import qualified Data.Csv as Cassava @@ -103,23 +103,20 @@ reader = Reader parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal parse iopts f t = do let rulesfile = mrules_file_ iopts - r <- liftIO $ readJournalFromCsv rulesfile f t - case r of Left e -> throwError e - Right pj -> - -- journalFinalise assumes the journal's items are - -- reversed, as produced by JournalReader's parser. - -- But here they are already properly ordered. So we'd - -- better preemptively reverse them once more. XXX inefficient - let pj' = journalReverse pj - -- apply any command line account aliases. Can fail with a bad replacement pattern. - in case journalApplyAliases (aliasesFromOpts iopts) pj' of - Left e -> throwError e - Right pj'' -> journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} f t pj'' + readJournalFromCsv rulesfile f t + -- journalFinalise assumes the journal's items are + -- reversed, as produced by JournalReader's parser. + -- But here they are already properly ordered. So we'd + -- better preemptively reverse them once more. XXX inefficient + <&> journalReverse + -- apply any command line account aliases. Can fail with a bad replacement pattern. + >>= liftEither . journalApplyAliases (aliasesFromOpts iopts) + >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} f t --- ** reading rules files --- *** rules utilities --- Not used by hledger; just for lib users, +-- Not used by hledger; just for lib users, -- | An pure-exception-throwing IO action that parses this file's content -- as CSV conversion rules, interpolating any included files first, -- and runs some extra validation checks. @@ -226,7 +223,7 @@ parseCsvRules = runParser (evalStateT rulesp defrules) -- | Return the validated rules, or an error. validateRules :: CsvRules -> Either String CsvRules validateRules rules = do - unless (isAssigned "date") $ Left "Please specify (at top level) the date field. Eg: date %1\n" + unless (isAssigned "date") $ Left "Please specify (at top level) the date field. Eg: date %1" Right rules where isAssigned f = isJust $ getEffectiveAssignment rules [] f @@ -568,7 +565,7 @@ conditionalblockp = do , fmap Just fieldassignmentp ]) when (null as) $ - customFailure $ parseErrorAt start $ "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)\n" + customFailure $ parseErrorAt start $ "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)" return $ CB{cbMatchers=ms, cbAssignments=as} "conditional block" @@ -588,10 +585,10 @@ conditionaltablep = do m <- matcherp' (char sep >> return ()) vs <- T.split (==sep) . T.pack <$> lift restofline if (length vs /= length fields) - then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d\n" (length fields) (length vs)) :: String) + then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d" (length fields) (length vs)) :: String) else return (m,vs) when (null body) $ - customFailure $ parseErrorAt start $ "start of conditional table found, but no assignment rules afterward\n" + customFailure $ parseErrorAt start $ "start of conditional table found, but no assignment rules afterward" return $ flip map body $ \(m,vs) -> CB{cbMatchers=[m], cbAssignments=zip fields vs} "conditional table" @@ -614,7 +611,7 @@ recordmatcherp end = do r <- regexp end return $ RecordMatcher p r -- when (null ps) $ - -- Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n" + -- Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)" "record matcher" -- | A single matcher for a specific field. A csv field reference @@ -686,93 +683,85 @@ regexp end = do -- 4. if the rules file didn't exist, create it with the default rules and filename -- -- 5. return the transactions as a Journal --- -readJournalFromCsv :: Maybe FilePath -> FilePath -> Text -> IO (Either String Journal) -readJournalFromCsv Nothing "-" _ = return $ Left "please use --rules-file when reading CSV from stdin" -readJournalFromCsv mrulesfile csvfile csvdata = - handle (\(e::IOException) -> return $ Left $ show e) $ do +-- +readJournalFromCsv :: Maybe FilePath -> FilePath -> Text -> ExceptT String IO Journal +readJournalFromCsv Nothing "-" _ = throwError "please use --rules-file when reading CSV from stdin" +readJournalFromCsv mrulesfile csvfile csvdata = do + -- parse the csv rules + let rulesfile = fromMaybe (rulesFileFor csvfile) mrulesfile + rulesfileexists <- liftIO $ doesFileExist rulesfile + rulestext <- liftIO $ if rulesfileexists + then do + dbg6IO "using conversion rules file" rulesfile + readFilePortably rulesfile >>= expandIncludes (takeDirectory rulesfile) + else + return $ defaultRulesText rulesfile + rules <- liftEither $ parseAndValidateCsvRules rulesfile rulestext + dbg6IO "csv rules" rules - -- make and throw an IO exception.. which we catch and convert to an Either above ? - let throwerr = throw . userError + -- parse the skip directive's value, if any + skiplines <- case getDirective "skip" rules of + Nothing -> return 0 + Just "" -> return 1 + Just s -> maybe (throwError $ "could not parse skip value: " ++ show s) return . readMay $ T.unpack s - -- parse the csv rules - let rulesfile = fromMaybe (rulesFileFor csvfile) mrulesfile - rulesfileexists <- doesFileExist rulesfile - rulestext <- - if rulesfileexists - then do - dbg6IO "using conversion rules file" rulesfile - readFilePortably rulesfile >>= expandIncludes (takeDirectory rulesfile) - else - return $ defaultRulesText rulesfile - rules <- either throwerr return $ parseAndValidateCsvRules rulesfile rulestext - dbg6IO "csv rules" rules + -- parse csv + let + -- parsec seems to fail if you pass it "-" here TODO: try again with megaparsec + parsecfilename = if csvfile == "-" then "(stdin)" else csvfile + separator = + case getDirective "separator" rules >>= parseSeparator of + Just c -> c + _ | ext == "ssv" -> ';' + _ | ext == "tsv" -> '\t' + _ -> ',' + where + ext = map toLower $ drop 1 $ takeExtension csvfile + dbg6IO "using separator" separator + csv <- dbg7 "parseCsv" <$> parseCsv separator parsecfilename csvdata + records <- liftEither $ dbg7 "validateCsv" <$> validateCsv rules skiplines csv + dbg6IO "first 3 csv records" $ take 3 records - -- parse the skip directive's value, if any - let skiplines = case getDirective "skip" rules of - Nothing -> 0 - Just "" -> 1 - Just s -> readDef (throwerr $ "could not parse skip value: " ++ show s) $ T.unpack s + -- identify header lines + -- let (headerlines, datalines) = identifyHeaderLines records + -- mfieldnames = lastMay headerlines - -- parse csv - let - -- parsec seems to fail if you pass it "-" here TODO: try again with megaparsec - parsecfilename = if csvfile == "-" then "(stdin)" else csvfile - separator = - case getDirective "separator" rules >>= parseSeparator of - Just c -> c - _ | ext == "ssv" -> ';' - _ | ext == "tsv" -> '\t' - _ -> ',' + let + -- convert CSV records to transactions, saving the CSV line numbers for error positions + txns = dbg7 "csv txns" $ snd $ mapAccumL + (\pos r -> + let + SourcePos name line col = pos + line' = (mkPos . (+1) . unPos) line + pos' = SourcePos name line' col + in + (pos', transactionFromCsvRecord pos rules r) + ) + (initialPos parsecfilename) records + + -- Ensure transactions are ordered chronologically. + -- First, if the CSV records seem to be most-recent-first (because + -- there's an explicit "newest-first" directive, or there's more + -- than one date and the first date is more recent than the last): + -- reverse them to get same-date transactions ordered chronologically. + txns' = + (if newestfirst || mdataseemsnewestfirst == Just True + then dbg7 "reversed csv txns" . reverse else id) + txns where - ext = map toLower $ drop 1 $ takeExtension csvfile - dbg6IO "using separator" separator - records <- (either throwerr id . - dbg7 "validateCsv" . validateCsv rules skiplines . - dbg7 "parseCsv") - `fmap` parseCsv separator parsecfilename csvdata - dbg6IO "first 3 csv records" $ take 3 records + newestfirst = dbg6 "newestfirst" $ isJust $ getDirective "newest-first" rules + mdataseemsnewestfirst = dbg6 "mdataseemsnewestfirst" $ + case nub $ map tdate txns of + ds | length ds > 1 -> Just $ head ds > last ds + _ -> Nothing + -- Second, sort by date. + txns'' = dbg7 "date-sorted csv txns" $ sortBy (comparing tdate) txns' - -- identify header lines - -- let (headerlines, datalines) = identifyHeaderLines records - -- mfieldnames = lastMay headerlines + liftIO $ when (not rulesfileexists) $ do + dbg1IO "creating conversion rules file" rulesfile + T.writeFile rulesfile rulestext - let - -- convert CSV records to transactions, saving the CSV line numbers for error positions - txns = dbg7 "csv txns" $ snd $ mapAccumL - (\pos r -> - let - SourcePos name line col = pos - line' = (mkPos . (+1) . unPos) line - pos' = SourcePos name line' col - in - (pos', transactionFromCsvRecord pos rules r) - ) - (initialPos parsecfilename) records - - -- Ensure transactions are ordered chronologically. - -- First, if the CSV records seem to be most-recent-first (because - -- there's an explicit "newest-first" directive, or there's more - -- than one date and the first date is more recent than the last): - -- reverse them to get same-date transactions ordered chronologically. - txns' = - (if newestfirst || mdataseemsnewestfirst == Just True - then dbg7 "reversed csv txns" . reverse else id) - txns - where - newestfirst = dbg6 "newestfirst" $ isJust $ getDirective "newest-first" rules - mdataseemsnewestfirst = dbg6 "mdataseemsnewestfirst" $ - case nub $ map tdate txns of - ds | length ds > 1 -> Just $ head ds > last ds - _ -> Nothing - -- Second, sort by date. - txns'' = dbg7 "date-sorted csv txns" $ sortBy (comparing tdate) txns' - - when (not rulesfileexists) $ do - dbg1IO "creating conversion rules file" rulesfile - T.writeFile rulesfile rulestext - - return $ Right nulljournal{jtxns=txns''} + return nulljournal{jtxns=txns''} -- | Parse special separator names TAB and SPACE, or return the first -- character. Return Nothing on empty string @@ -782,8 +771,8 @@ parseSeparator = specials . T.toLower specials "tab" = Just '\t' specials xs = fst <$> T.uncons xs -parseCsv :: Char -> FilePath -> Text -> IO (Either String CSV) -parseCsv separator filePath csvdata = +parseCsv :: Char -> FilePath -> Text -> ExceptT String IO CSV +parseCsv separator filePath csvdata = ExceptT $ case filePath of "-" -> parseCassava separator "(stdin)" <$> T.getContents _ -> return $ if T.null csvdata then Right mempty else parseCassava separator filePath csvdata @@ -811,9 +800,8 @@ printCSV = TB.toLazyText . unlinesB . map printRecord printField = wrap "\"" "\"" . T.replace "\"" "\"\"" -- | Return the cleaned up and validated CSV data (can be empty), or an error. -validateCsv :: CsvRules -> Int -> Either String CSV -> Either String [CsvRecord] -validateCsv _ _ (Left err) = Left err -validateCsv rules numhdrlines (Right rs) = validate $ applyConditionalSkips $ drop numhdrlines $ filternulls rs +validateCsv :: CsvRules -> Int -> CSV -> Either String [CsvRecord] +validateCsv rules numhdrlines = validate . applyConditionalSkips . drop numhdrlines . filternulls where filternulls = filter (/=[""]) skipCount r = diff --git a/hledger-ui/Hledger/UI/ErrorScreen.hs b/hledger-ui/Hledger/UI/ErrorScreen.hs index 256e815ab..7d8fb907b 100644 --- a/hledger-ui/Hledger/UI/ErrorScreen.hs +++ b/hledger-ui/Hledger/UI/ErrorScreen.hs @@ -15,7 +15,7 @@ where import Brick -- import Brick.Widgets.Border ("border") import Control.Monad -import Control.Monad.IO.Class (liftIO) +import Control.Monad.Except (liftIO) import Data.Time.Calendar (Day) import Data.Void (Void) import Graphics.Vty (Event(..),Key(..),Modifier(..)) @@ -155,7 +155,7 @@ uiReloadJournal :: CliOpts -> Day -> UIState -> IO UIState uiReloadJournal copts d ui = do ej <- let copts' = enableForecastPreservingPeriod ui copts - in journalReload copts' + in runExceptT $ journalReload copts' return $ case ej of Right j -> regenerateScreens j d ui Left err -> @@ -168,13 +168,11 @@ uiReloadJournal copts d ui = do -- since the provided options or today-date may have changed. uiReloadJournalIfChanged :: CliOpts -> Day -> Journal -> UIState -> IO UIState uiReloadJournalIfChanged copts d j ui = do - (ej, _changed) <- - let copts' = enableForecastPreservingPeriod ui copts - in journalReloadIfChanged copts' d j + let copts' = enableForecastPreservingPeriod ui copts + ej <- runExceptT $ journalReloadIfChanged copts' d j return $ case ej of - Right j' -> regenerateScreens j' d ui - Left err -> - case ui of + Right (j', _) -> regenerateScreens j' d ui + Left err -> case ui of UIState{aScreen=s@ErrorScreen{}} -> ui{aScreen=s{esError=err}} _ -> screenEnter d errorScreen{esError=err} ui diff --git a/hledger-ui/Hledger/UI/TransactionScreen.hs b/hledger-ui/Hledger/UI/TransactionScreen.hs index f33a52654..0726fe409 100644 --- a/hledger-ui/Hledger/UI/TransactionScreen.hs +++ b/hledger-ui/Hledger/UI/TransactionScreen.hs @@ -9,7 +9,7 @@ module Hledger.UI.TransactionScreen ) where import Control.Monad -import Control.Monad.IO.Class (liftIO) +import Control.Monad.Except (liftIO) import Data.List import Data.Maybe import qualified Data.Text as T @@ -174,7 +174,7 @@ tsHandle ui@UIState{aScreen=TransactionScreen{tsTransaction=(i,t), tsTransaction p = reportPeriod ui e | e `elem` [VtyEvent (EvKey (KChar 'g') []), AppEvent FileChange] -> do -- plog (if e == AppEvent FileChange then "file change" else "manual reload") "" `seq` return () - ej <- liftIO $ journalReload copts + ej <- liftIO . runExceptT $ journalReload copts case ej of Left err -> continue $ screenEnter d errorScreen{esError=err} ui Right j' -> continue $ regenerateScreens j' d ui diff --git a/hledger-ui/hledger-ui.cabal b/hledger-ui/hledger-ui.cabal index 2859f68e4..d2da958ed 100644 --- a/hledger-ui/hledger-ui.cabal +++ b/hledger-ui/hledger-ui.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack @@ -82,6 +82,7 @@ executable hledger-ui , megaparsec >=7.0.0 && <9.3 , microlens >=0.4 , microlens-platform >=0.2.3.1 + , mtl >=2.2.1 , process >=1.2 , safe >=0.2 , split >=0.1 diff --git a/hledger-ui/package.yaml b/hledger-ui/package.yaml index c1b34825c..258428015 100644 --- a/hledger-ui/package.yaml +++ b/hledger-ui/package.yaml @@ -57,6 +57,7 @@ dependencies: - microlens >=0.4 - microlens-platform >=0.2.3.1 - megaparsec >=7.0.0 && <9.3 +- mtl >=2.2.1 - process >=1.2 - safe >=0.2 - split >=0.1 diff --git a/hledger-web/Hledger/Web/Foundation.hs b/hledger-web/Hledger/Web/Foundation.hs index 5ace13192..954799d39 100644 --- a/hledger-web/Hledger/Web/Foundation.hs +++ b/hledger-web/Hledger/Web/Foundation.hs @@ -17,6 +17,7 @@ module Hledger.Web.Foundation where import Control.Applicative ((<|>)) import Control.Monad (join, when) +import Control.Monad.Except (runExceptT) import qualified Data.ByteString.Char8 as BC import Data.Traversable (for) import Data.IORef (IORef, readIORef, writeIORef) @@ -256,16 +257,16 @@ shouldShowSidebar = do -- ui message. getCurrentJournal :: IORef Journal -> CliOpts -> Day -> Handler (Journal, Maybe String) getCurrentJournal jref opts d = do - -- XXX put this inside atomicModifyIORef' for thread safety - j <- liftIO (readIORef jref) - (ej, changed) <- liftIO $ journalReloadIfChanged opts d j -- re-apply any initial filter specified at startup let initq = _rsQuery $ reportspec_ opts - case (changed, filterJournalTransactions initq <$> ej) of - (False, _) -> return (j, Nothing) - (True, Right j') -> do - liftIO $ writeIORef jref j' - return (j',Nothing) - (True, Left e) -> do + -- XXX put this inside atomicModifyIORef' for thread safety + j <- liftIO (readIORef jref) + ej <- liftIO . runExceptT $ journalReloadIfChanged opts d j + case ej of + Left e -> do setMessage "error while reading journal" return (j, Just e) + Right (j', True) -> do + liftIO . writeIORef jref $ filterJournalTransactions initq j' + return (j',Nothing) + Right (_, False) -> return (j, Nothing) diff --git a/hledger-web/Hledger/Web/Handler/EditR.hs b/hledger-web/Hledger/Web/Handler/EditR.hs index e55821601..7fb64a780 100644 --- a/hledger-web/Hledger/Web/Handler/EditR.hs +++ b/hledger-web/Hledger/Web/Handler/EditR.hs @@ -10,6 +10,7 @@ module Hledger.Web.Handler.EditR , postEditR ) where +import Control.Monad.Except (runExceptT) import Hledger.Web.Import import Hledger.Web.Widget.Common (fromFormSuccess, helplink, journalFile404, writeJournalTextIfValidAndChanged) @@ -36,7 +37,7 @@ postEditR f = do (f', txt) <- journalFile404 f j ((res, view), enctype) <- runFormPost (editForm f' txt) newtxt <- fromFormSuccess (showForm view enctype) res - writeJournalTextIfValidAndChanged f newtxt >>= \case + runExceptT (writeJournalTextIfValidAndChanged f newtxt) >>= \case Left e -> do setMessage $ "Failed to load journal: " <> toHtml e showForm view enctype diff --git a/hledger-web/Hledger/Web/Handler/UploadR.hs b/hledger-web/Hledger/Web/Handler/UploadR.hs index 77c67309d..2b657eb1d 100644 --- a/hledger-web/Hledger/Web/Handler/UploadR.hs +++ b/hledger-web/Hledger/Web/Handler/UploadR.hs @@ -9,6 +9,7 @@ module Hledger.Web.Handler.UploadR , postUploadR ) where +import Control.Monad.Except (runExceptT) import qualified Data.ByteString.Lazy as BL import Data.Conduit (connect) import Data.Conduit.Binary (sinkLbs) @@ -52,7 +53,7 @@ postUploadR f = do "where the transcoding should be handled by the browser." showForm view enctype Right newtxt -> return newtxt - writeJournalTextIfValidAndChanged f newtxt >>= \case + runExceptT (writeJournalTextIfValidAndChanged f newtxt) >>= \case Left e -> do setMessage $ "Failed to load journal: " <> toHtml e showForm view enctype diff --git a/hledger-web/Hledger/Web/Test.hs b/hledger-web/Hledger/Web/Test.hs index 4b075d2d6..27e7cc67f 100644 --- a/hledger-web/Hledger/Web/Test.hs +++ b/hledger-web/Hledger/Web/Test.hs @@ -4,7 +4,6 @@ module Hledger.Web.Test ( hledgerWebTest ) where -import Control.Monad.Except (runExceptT) import qualified Data.Text as T import Test.Hspec (hspec) import Yesod.Default.Config diff --git a/hledger-web/Hledger/Web/Widget/Common.hs b/hledger-web/Hledger/Web/Widget/Common.hs index 2ce97f20e..4d3e20542 100644 --- a/hledger-web/Hledger/Web/Widget/Common.hs +++ b/hledger-web/Hledger/Web/Widget/Common.hs @@ -19,6 +19,7 @@ module Hledger.Web.Widget.Common , replaceInacct ) where +import Control.Monad.Except (ExceptT, mapExceptT) import Data.Foldable (find, for_) import Data.List (elemIndex) import Data.Text (Text) @@ -59,17 +60,15 @@ fromFormSuccess _ (FormSuccess a) = pure a -- The file will be written (if changed) with the current system's native -- line endings (see writeFileWithBackupIfChanged). -- -writeJournalTextIfValidAndChanged :: MonadHandler m => FilePath -> Text -> m (Either String ()) -writeJournalTextIfValidAndChanged f t = do +writeJournalTextIfValidAndChanged :: MonadHandler m => FilePath -> Text -> ExceptT String m () +writeJournalTextIfValidAndChanged f t = mapExceptT liftIO $ do -- Ensure unix line endings, since both readJournal (cf -- formatdirectivep, #1194) writeFileWithBackupIfChanged require them. -- XXX klunky. Any equivalent of "hSetNewlineMode h universalNewlineMode" for form posts ? let t' = T.replace "\r" "" t - liftIO (readJournal definputopts (Just f) t') >>= \case - Left e -> return (Left e) - Right _ -> do - _ <- liftIO (writeFileWithBackupIfChanged f t') - return (Right ()) + j <- readJournal definputopts (Just f) t' + _ <- liftIO $ j `seq` writeFileWithBackupIfChanged f t' -- Only write backup if the journal didn't error + return () -- | Link to a topic in the manual. helplink :: Text -> Text -> HtmlUrl r diff --git a/hledger/Hledger/Cli/Commands.hs b/hledger/Hledger/Cli/Commands.hs index f040006dc..070658d05 100644 --- a/hledger/Hledger/Cli/Commands.hs +++ b/hledger/Hledger/Cli/Commands.hs @@ -292,8 +292,8 @@ tests_Commands = testGroup "Commands" [ let ignoresourcepos j = j{jtxns=map (\t -> t{tsourcepos=nullsourcepos}) (jtxns j)} sameParse str1 str2 = do - j1 <- readJournal definputopts Nothing str1 >>= either error' (return . ignoresourcepos) -- PARTIAL: - j2 <- readJournal definputopts Nothing str2 >>= either error' (return . ignoresourcepos) + j1 <- ignoresourcepos <$> readJournal' str1 -- PARTIAL: + j2 <- ignoresourcepos <$> readJournal' str2 -- PARTIAL: j1 @?= j2{jlastreadtime=jlastreadtime j1, jfiles=jfiles j1} --, jparsestate=jparsestate j1} sameParse ("2008/12/07 One\n alpha $-1\n beta $1\n" <> @@ -310,19 +310,19 @@ tests_Commands = testGroup "Commands" [ ) ,testCase "preserves \"virtual\" posting type" $ do - j <- readJournal definputopts Nothing "apply account test\n2008/12/07 One\n (from) $-1\n (to) $1\n" >>= either error' return -- PARTIAL: + j <- readJournal' "apply account test\n2008/12/07 One\n (from) $-1\n (to) $1\n" -- PARTIAL: let p = head $ tpostings $ head $ jtxns j paccount p @?= "test:from" ptype p @?= VirtualPosting ] ,testCase "alias directive" $ do - j <- readJournal definputopts Nothing "!alias expenses = equity:draw:personal\n1/1\n (expenses:food) 1\n" >>= either error' return -- PARTIAL: + j <- readJournal' "!alias expenses = equity:draw:personal\n1/1\n (expenses:food) 1\n" -- PARTIAL: let p = head $ tpostings $ head $ jtxns j paccount p @?= "equity:draw:personal:food" ,testCase "Y default year directive" $ do - j <- readJournal definputopts Nothing defaultyear_journal_txt >>= either error' return -- PARTIAL: + j <- readJournal' defaultyear_journal_txt -- PARTIAL: tdate (head $ jtxns j) @?= fromGregorian 2009 1 1 ,testCase "ledgerAccountNames" $ diff --git a/hledger/Hledger/Cli/Commands/Diff.hs b/hledger/Hledger/Cli/Commands/Diff.hs index a968519a1..759bb55f9 100644 --- a/hledger/Hledger/Cli/Commands/Diff.hs +++ b/hledger/Hledger/Cli/Commands/Diff.hs @@ -12,6 +12,7 @@ module Hledger.Cli.Commands.Diff ( ,diff ) where +import Control.Monad.Except (runExceptT) import Data.List.Extra ((\\), groupSortOn, nubBy, sortBy) import Data.Function (on) import Data.Ord (comparing) @@ -82,7 +83,8 @@ matching ppl ppr = do readJournalFile' :: FilePath -> IO Journal readJournalFile' fn = - readJournalFile definputopts{balancingopts_=defbalancingopts{ignore_assertions_=True}} fn >>= either error' return -- PARTIAL: + runExceptT (readJournalFile definputopts{balancingopts_=defbalancingopts{ignore_assertions_=True}} fn) + >>= either error' return -- PARTIAL: matchingPostings :: AccountName -> Journal -> [PostingWithPath] matchingPostings acct j = filter ((== acct) . paccount . ppposting) $ allPostingsWithPath j diff --git a/hledger/Hledger/Cli/Commands/Import.hs b/hledger/Hledger/Cli/Commands/Import.hs index 87efec213..996fef701 100755 --- a/hledger/Hledger/Cli/Commands/Import.hs +++ b/hledger/Hledger/Cli/Commands/Import.hs @@ -8,6 +8,7 @@ module Hledger.Cli.Commands.Import ( where import Control.Monad +import Control.Monad.Except (runExceptT) import Data.List import qualified Data.Text.IO as T import Hledger @@ -46,7 +47,7 @@ importcmd opts@CliOpts{rawopts_=rawopts,inputopts_=iopts} j = do case inputfiles of [] -> error' "please provide one or more input files as arguments" -- PARTIAL: fs -> do - enewj <- readJournalFiles iopts' fs + enewj <- runExceptT $ readJournalFiles iopts' fs case enewj of Left e -> error' e Right newj -> diff --git a/hledger/Hledger/Cli/Utils.hs b/hledger/Hledger/Cli/Utils.hs index 60835ebf4..c7a583b9a 100644 --- a/hledger/Hledger/Cli/Utils.hs +++ b/hledger/Hledger/Cli/Utils.hs @@ -29,7 +29,9 @@ module Hledger.Cli.Utils tests_Cli_Utils, ) where + import Control.Exception as C +import Control.Monad.Except (ExceptT, runExceptT, liftIO) import Data.List import Data.Maybe @@ -72,9 +74,8 @@ withJournalDo opts cmd = do -- it's stdin, or it doesn't exist and we are adding. We read it strictly -- to let the add command work. journalpaths <- journalFilePathFromOpts opts - files <- readJournalFiles (inputopts_ opts) journalpaths - let transformed = journalTransform opts <$> files - either error' cmd transformed -- PARTIAL: + j <- runExceptT $ journalTransform opts <$> readJournalFiles (inputopts_ opts) journalpaths + either error' cmd j -- PARTIAL: -- | Apply some extra post-parse transformations to the journal, if -- specified by options. These happen after journal validation, but @@ -132,29 +133,28 @@ writeOutputLazyText opts s = do -- Returns a journal or error message, and a flag indicating whether -- it was re-read or not. Like withJournalDo and journalReload, reads -- the full journal, without filtering. -journalReloadIfChanged :: CliOpts -> Day -> Journal -> IO (Either String Journal, Bool) +journalReloadIfChanged :: CliOpts -> Day -> Journal -> ExceptT String IO (Journal, Bool) journalReloadIfChanged opts _d j = do let maybeChangedFilename f = do newer <- journalFileIsNewer j f return $ if newer then Just f else Nothing - changedfiles <- catMaybes `fmap` mapM maybeChangedFilename (journalFilePaths j) + changedfiles <- liftIO $ catMaybes <$> mapM maybeChangedFilename (journalFilePaths j) if not $ null changedfiles then do -- XXX not sure why we use cmdarg's verbosity here, but keep it for now - verbose <- isLoud - when (verbose || debugLevel >= 6) $ printf "%s has changed, reloading\n" (head changedfiles) - ej <- journalReload opts - return (ej, True) + verbose <- liftIO isLoud + when (verbose || debugLevel >= 6) . liftIO $ printf "%s has changed, reloading\n" (head changedfiles) + newj <- journalReload opts + return (newj, True) else - return (Right j, False) + return (j, False) -- | Re-read the journal file(s) specified by options, applying any -- transformations specified by options. Or return an error string. -- Reads the full journal, without filtering. -journalReload :: CliOpts -> IO (Either String Journal) +journalReload :: CliOpts -> ExceptT String IO Journal journalReload opts = do - journalpaths <- dbg6 "reloading files" <$> journalFilePathFromOpts opts - files <- readJournalFiles (inputopts_ opts) journalpaths - return $ journalTransform opts <$> files + journalpaths <- liftIO $ dbg6 "reloading files" <$> journalFilePathFromOpts opts + journalTransform opts <$> readJournalFiles (inputopts_ opts) journalpaths -- | Has the specified file changed since the journal was last read ? -- Typically this is one of the journal's journalFilePaths. These are diff --git a/hledger/test/csv.test b/hledger/test/csv.test index 5381c9718..b258d4f0d 100644 --- a/hledger/test/csv.test +++ b/hledger/test/csv.test @@ -759,7 +759,7 @@ $ ./csvtest.sh >=0 -# 39. Insfficient number of values in tabular rules error +# 39. Insufficient number of values in tabular rules error < 10/2009/09,Flubber Co,50 10/2009/09,Blubber Co,150 @@ -774,13 +774,12 @@ if|account2|comment %description Flubber|acct| $ ./csvtest.sh >2 -hledger: user error (input.rules:6:1: +hledger: input.rules:6:1: | 6 | %amount 150|acct2 | ^ line of conditional table should have 2 values, but this one has only 1 -) >=1 # 40. unindented condition block error @@ -797,14 +796,13 @@ account2 acct comment cmt $ ./csvtest.sh >2 -hledger: user error (input.rules:5:1: +hledger: input.rules:5:1: | 5 | if Flubber | ^ start of conditional block found, but no assignment rules afterward (assignment rules in a conditional block should be indented) -) >=1 # 41. Assignment to custom field (#1264) + spaces after the if (#1120) @@ -824,13 +822,13 @@ if Flubber account2 %myaccount2 $ ./csvtest.sh >2 -hledger: user error (input.rules:6:3: +hledger: input.rules:6:3: | 6 | myaccount2 acct | ^^^^^^^^^^^^ unexpected "myaccount2 a" expecting conditional block -) + >=1 # 42. Rules override each other in the order listed in the file @@ -872,14 +870,13 @@ if account2 comment %description Flubber acct $ ./csvtest.sh >2 -hledger: user error (input.rules:5:1: +hledger: input.rules:5:1: | 5 | if account2 comment | ^ start of conditional block found, but no assignment rules afterward (assignment rules in a conditional block should be indented) -) >=1 # 44. handle conditions with & operator