extra: update, stackify hledger-check-dates
This commit is contained in:
parent
7f5e09096f
commit
e7c457f970
@ -1,4 +1,9 @@
|
||||
#!/usr/bin/env runhaskell
|
||||
#!/usr/bin/env stack
|
||||
{- stack runghc --verbosity info
|
||||
--package hledger-lib
|
||||
--package hledger
|
||||
-}
|
||||
|
||||
{-|
|
||||
hledger-check-dates [--strict] [--date2] [-f JOURNALFILE]
|
||||
|
||||
@ -12,19 +17,19 @@ import Text.Printf
|
||||
|
||||
argsmode :: Mode RawOpts
|
||||
argsmode = (defCommandMode ["check-dates"])
|
||||
{ modeHelp = "check that transactions' date are monotonically increasing"
|
||||
, modeGroupFlags = Group
|
||||
{ groupNamed =
|
||||
[ ("Input",inputflags)
|
||||
, ("Reporting",reportflags)
|
||||
, ("Misc",helpflags)
|
||||
]
|
||||
,groupUnnamed = [
|
||||
flagNone ["strict"] (\opts -> setboolopt "strict" opts) "makes date comparing strict"
|
||||
]
|
||||
, groupHidden = []
|
||||
}
|
||||
}
|
||||
{ modeHelp = "check that transactions' date are monotonically increasing"
|
||||
, modeGroupFlags = Group
|
||||
{ groupNamed =
|
||||
[ ("Input",inputflags)
|
||||
, ("Reporting",reportflags)
|
||||
, ("Misc",helpflags)
|
||||
]
|
||||
,groupUnnamed = [
|
||||
flagNone ["strict"] (\opts -> setboolopt "strict" opts) "makes date comparing strict"
|
||||
]
|
||||
, groupHidden = []
|
||||
}
|
||||
}
|
||||
|
||||
data FoldAcc a b = FoldAcc
|
||||
{ fa_error :: Maybe a
|
||||
@ -32,50 +37,50 @@ data FoldAcc a b = FoldAcc
|
||||
}
|
||||
|
||||
foldWhile :: (a -> FoldAcc a b -> FoldAcc a b) -> FoldAcc a b -> [a] -> FoldAcc a b
|
||||
foldWhile fold acc [] = acc
|
||||
foldWhile _ acc [] = acc
|
||||
foldWhile fold acc (a:as) =
|
||||
case fold a acc of
|
||||
acc@FoldAcc{fa_error=Just a} -> acc
|
||||
acc -> foldWhile fold acc 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
|
||||
checkTransactions compare ts =
|
||||
foldWhile fold FoldAcc{fa_error=Nothing, fa_previous=Nothing} ts
|
||||
where
|
||||
fold current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current}
|
||||
fold current acc@FoldAcc{fa_previous=Just previous} =
|
||||
if compare previous current
|
||||
then acc{fa_previous=Just current}
|
||||
else acc{fa_error=Just current}
|
||||
foldWhile fold FoldAcc{fa_error=Nothing, fa_previous=Nothing} ts
|
||||
where
|
||||
fold current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current}
|
||||
fold current acc@FoldAcc{fa_previous=Just previous} =
|
||||
if compare previous current
|
||||
then acc{fa_previous=Just current}
|
||||
else acc{fa_error=Just current}
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts <- getCliOpts argsmode
|
||||
withJournalDo opts $
|
||||
\cliopts@CliOpts{rawopts_=opts,reportopts_=ropts} j -> do
|
||||
d <- getCurrentDay
|
||||
let ropts_ = ropts{flat_=True}
|
||||
let q = queryFromOpts d ropts_
|
||||
let ts = filter (q `matchesTransaction`) $
|
||||
jtxns $ journalSelectingAmountFromOpts ropts j
|
||||
let strict = boolopt "strict" opts
|
||||
let date = transactionDateFn ropts
|
||||
let compare a b =
|
||||
if strict
|
||||
then date a < date b
|
||||
else date a <= date b
|
||||
case checkTransactions compare ts of
|
||||
FoldAcc{fa_previous=Nothing} -> putStrLn "ok (empty journal)"
|
||||
FoldAcc{fa_error=Nothing} -> putStrLn "ok"
|
||||
FoldAcc{fa_error=Just error, fa_previous=Just previous} ->
|
||||
putStrLn $ printf ("ERROR: transaction out of%s date order"
|
||||
++ "\nPrevious date: %s"
|
||||
++ "\nDate: %s"
|
||||
++ "\nLocation: %s"
|
||||
++ "\nTransaction:\n\n%s")
|
||||
(if strict then " STRICT" else "")
|
||||
(show $ date previous)
|
||||
(show $ date error)
|
||||
(show $ tsourcepos error)
|
||||
(showTransactionUnelided error)
|
||||
opts <- getCliOpts argsmode
|
||||
withJournalDo opts $
|
||||
\CliOpts{rawopts_=opts,reportopts_=ropts} j -> do
|
||||
d <- getCurrentDay
|
||||
let ropts_ = ropts{accountlistmode_=ALFlat}
|
||||
let q = queryFromOpts d ropts_
|
||||
let ts = filter (q `matchesTransaction`) $
|
||||
jtxns $ journalSelectingAmountFromOpts ropts j
|
||||
let strict = boolopt "strict" opts
|
||||
let date = transactionDateFn ropts
|
||||
let compare a b =
|
||||
if strict
|
||||
then date a < date b
|
||||
else date a <= date b
|
||||
case checkTransactions compare ts of
|
||||
FoldAcc{fa_previous=Nothing} -> putStrLn "ok (empty journal)"
|
||||
FoldAcc{fa_error=Nothing} -> putStrLn "ok"
|
||||
FoldAcc{fa_error=Just error, fa_previous=Just previous} ->
|
||||
putStrLn $ printf ("ERROR: transaction out of%s date order"
|
||||
++ "\nPrevious date: %s"
|
||||
++ "\nDate: %s"
|
||||
++ "\nLocation: %s"
|
||||
++ "\nTransaction:\n\n%s")
|
||||
(if strict then " STRICT" else "")
|
||||
(show $ date previous)
|
||||
(show $ date error)
|
||||
(show $ tsourcepos error)
|
||||
(showTransactionUnelided error)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user