mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-20 02:37:12 +03:00
;check: ordereddates/uniqueleafnames: print on stderr, refactor
This commit is contained in:
parent
1d4c4c5b8b
commit
4491325bb0
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
@ -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.
|
||||
|
Loading…
Reference in New Issue
Block a user