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