diff --git a/hledger/Hledger/Cli/Commands/Check.hs b/hledger/Hledger/Cli/Commands/Check.hs index 5983f2a91..e7f872b43 100644 --- a/hledger/Hledger/Cli/Commands/Check.hs +++ b/hledger/Hledger/Cli/Commands/Check.hs @@ -41,6 +41,16 @@ check copts@CliOpts{rawopts_} j = do (unknowns@(_:_), _) -> error' $ "These checks are unknown: "++unwords unknowns ([], checks) -> forM_ checks $ runCheck copts' j +-- | Regenerate this CliOpts' report specification, after updating its +-- underlying report options with the given update function. +-- This can raise an error if there is a problem eg due to missing or +-- unparseable options data. See also updateReportSpecFromOpts. +cliOptsUpdateReportSpecWith :: (ReportOpts -> ReportOpts) -> CliOpts -> CliOpts +cliOptsUpdateReportSpecWith roptsupdate copts@CliOpts{reportspec_} = + case updateReportSpecWith roptsupdate reportspec_ of + Left e -> error' e -- PARTIAL: + Right rs -> copts{reportspec_=rs} + -- | A type of error check that we can perform on the data. -- (Currently, just the optional checks that only the check command -- can do; not the checks done by default or with --strict.) @@ -74,32 +84,23 @@ parseCheckArgument s = -- | Run the named error check, possibly with some arguments, -- on this journal with these options. runCheck :: CliOpts -> Journal -> (Check,[String]) -> IO () -runCheck copts@CliOpts{rawopts_} j (check,args) = - case check of - Accounts -> case journalCheckAccountsDeclared j of - Right () -> return () - Left err -> hPutStrLn stderr ("Error: "++err) >> exitFailure - Commodities -> case journalCheckCommoditiesDeclared j of - Right () -> return () - Left err -> hPutStrLn stderr ("Error: "++err) >> exitFailure - Ordereddates -> journalCheckOrdereddates copts' j - Payees -> case journalCheckPayeesDeclared j of - Right () -> return () - Left err -> hPutStrLn stderr ("Error: "++err) >> exitFailure - Uniqueleafnames -> journalCheckUniqueleafnames j - where - -- Hack: append the provided args to the raw opts, - -- in case the check can use them (like checkdates --unique). +runCheck copts@CliOpts{rawopts_} j (check,args) = do + let + -- XXX drop this ? + -- Hack: append the provided args to the raw opts, for checks + -- which can use them (just journalCheckOrdereddates rignt now + -- which has some flags from the old checkdates command). -- Does not bother to regenerate the derived data (ReportOpts, ReportSpec..), -- so those may be inconsistent. copts' = copts{rawopts_=appendopts (map (,"") args) rawopts_} --- | Regenerate this CliOpts' report specification, after updating its --- underlying report options with the given update function. --- This can raise an error if there is a problem eg due to missing or --- unparseable options data. See also updateReportSpecFromOpts. -cliOptsUpdateReportSpecWith :: (ReportOpts -> ReportOpts) -> CliOpts -> CliOpts -cliOptsUpdateReportSpecWith roptsupdate copts@CliOpts{reportspec_} = - case updateReportSpecWith roptsupdate reportspec_ of - Left e -> error' e -- PARTIAL: - Right rs -> copts{reportspec_=rs} + results = case check of + Accounts -> journalCheckAccountsDeclared j + Commodities -> journalCheckCommoditiesDeclared j + Ordereddates -> journalCheckOrdereddates copts' j + Payees -> journalCheckPayeesDeclared j + Uniqueleafnames -> journalCheckUniqueleafnames j + + case results of + Right () -> return () + Left err -> hPutStrLn stderr ("Error: "++err) >> exitFailure diff --git a/hledger/Hledger/Cli/Commands/Check/Ordereddates.hs b/hledger/Hledger/Cli/Commands/Check/Ordereddates.hs index 5b2f299eb..d3598344f 100755 --- a/hledger/Hledger/Cli/Commands/Check/Ordereddates.hs +++ b/hledger/Hledger/Cli/Commands/Check/Ordereddates.hs @@ -5,16 +5,14 @@ where import Hledger import Hledger.Cli.CliOptions -import System.Exit import Text.Printf -journalCheckOrdereddates :: CliOpts -> Journal -> IO () +journalCheckOrdereddates :: CliOpts -> Journal -> Either String () journalCheckOrdereddates CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do let ropts = (rsOpts rspec){accountlistmode_=ALFlat} let ts = filter (rsQuery rspec `matchesTransaction`) $ jtxns $ journalSelectingAmountFromOpts ropts j - let unique = boolopt "--unique" rawopts -- TEMP: it's this for hledger check dates - || boolopt "unique" rawopts -- and this for hledger check-dates (for some reason) + let unique = boolopt "--unique" rawopts let date = transactionDateFn ropts let compare a b = if unique @@ -29,26 +27,18 @@ journalCheckOrdereddates CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do positionstr = showGenericSourcePos $ tsourcepos error txn1str = linesPrepend " " $ showTransaction previous txn2str = linesPrepend2 "> " " " $ showTransaction error - printf "Error: transaction date is out of order%s\nat %s:\n\n%s" + Left $ printf "transaction date is out of order%s\nat %s:\n\n%s" uniquestr positionstr (txn1str ++ txn2str) - exitFailure data FoldAcc a b = FoldAcc { fa_error :: Maybe a , fa_previous :: Maybe b } -foldWhile :: (a -> FoldAcc a b -> FoldAcc a b) -> FoldAcc a b -> [a] -> FoldAcc a b -foldWhile _ acc [] = acc -foldWhile fold acc (a:as) = - case fold a acc of - acc@FoldAcc{fa_error=Just _} -> acc - acc -> foldWhile fold acc as - checkTransactions :: (Transaction -> Transaction -> Bool) - -> [Transaction] -> FoldAcc Transaction Transaction + -> [Transaction] -> FoldAcc Transaction Transaction checkTransactions compare = foldWhile f FoldAcc{fa_error=Nothing, fa_previous=Nothing} where f current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current} @@ -56,3 +46,10 @@ checkTransactions compare = foldWhile f FoldAcc{fa_error=Nothing, fa_previous=No if compare previous current then acc{fa_previous=Just current} else acc{fa_error=Just current} + +foldWhile :: (a -> FoldAcc a b -> FoldAcc a b) -> FoldAcc a b -> [a] -> FoldAcc a b +foldWhile _ acc [] = acc +foldWhile fold acc (a:as) = + case fold a acc of + acc@FoldAcc{fa_error=Just _} -> acc + acc -> foldWhile fold acc as diff --git a/hledger/Hledger/Cli/Commands/Check/Uniqueleafnames.hs b/hledger/Hledger/Cli/Commands/Check/Uniqueleafnames.hs index 7ba9e99dc..01f18b713 100755 --- a/hledger/Hledger/Cli/Commands/Check/Uniqueleafnames.hs +++ b/hledger/Hledger/Cli/Commands/Check/Uniqueleafnames.hs @@ -9,21 +9,18 @@ import Data.List.Extra (nubSort) import qualified Data.Text as T import Hledger import Text.Printf -import System.Exit (exitFailure) -import Control.Monad (when) +journalCheckUniqueleafnames :: Journal -> Either String () journalCheckUniqueleafnames j = do let dupes = checkdupes' $ accountsNames j - when (not $ null dupes) $ do + if null dupes + then Right () + else Left $ -- XXX make output more like Checkdates.hs, Check.hs etc. - mapM_ render dupes - exitFailure - -accountsNames :: Journal -> [(String, AccountName)] -accountsNames j = map leafAndAccountName as - where leafAndAccountName a = (T.unpack $ accountLeafName a, a) - ps = journalPostings j - as = nubSort $ map paccount ps + concatMap render dupes + where + render (leafName, accountNameL) = + printf "%s as %s\n" leafName (intercalate ", " (map T.unpack accountNameL)) checkdupes' :: (Ord k, Eq k) => [(k, v)] -> [(k, [v])] checkdupes' l = zip dupLeafs dupAccountNames @@ -34,5 +31,8 @@ checkdupes' l = zip dupLeafs dupAccountNames . groupBy ((==) `on` fst) . sortBy (compare `on` fst) -render :: (String, [AccountName]) -> IO () -render (leafName, accountNameL) = printf "%s as %s\n" leafName (intercalate ", " (map T.unpack accountNameL)) +accountsNames :: Journal -> [(String, AccountName)] +accountsNames j = map leafAndAccountName as + where leafAndAccountName a = (T.unpack $ accountLeafName a, a) + ps = journalPostings j + as = nubSort $ map paccount ps diff --git a/hledger/test/check-ordereddates.test b/hledger/test/check-ordereddates.test index be703c865..d5334ee76 100644 --- a/hledger/test/check-ordereddates.test +++ b/hledger/test/check-ordereddates.test @@ -12,10 +12,9 @@ $ hledger -f- check ordereddates 2020-01-01 (a) 1 $ hledger -f- check ordereddates -> /transaction date is out of order/ +>2 /transaction date is out of order/ >=1 # XXX -# make it >2 # With --date2, it checks secondary dates instead. # With --strict, dates must also be unique. # With a query, only matched transactions' dates are checked. diff --git a/hledger/test/check-uniqueleafnames.test b/hledger/test/check-uniqueleafnames.test index 3b4bd84c2..ed63e2140 100644 --- a/hledger/test/check-uniqueleafnames.test +++ b/hledger/test/check-uniqueleafnames.test @@ -11,10 +11,10 @@ $ hledger -f- check uniqueleafnames (a) 1 (b:a) 1 $ hledger -f- check uniqueleafnames -> /a as a, b:a/ +>2 /a as a, b:a/ >=1 # XXX -# make it >2; improve message +# improve message # Reports account names having the same leaf but different prefixes. # In other words, two or more leaves that are categorized differently. # Reads the default journal file, or another specified as an argument.