extra: update, stackify hledger-check-dates

This commit is contained in:
Simon Michael 2016-05-19 16:29:39 -07:00
parent 7f5e09096f
commit e7c457f970

View File

@ -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] hledger-check-dates [--strict] [--date2] [-f JOURNALFILE]
@ -12,19 +17,19 @@ import Text.Printf
argsmode :: Mode RawOpts argsmode :: Mode RawOpts
argsmode = (defCommandMode ["check-dates"]) argsmode = (defCommandMode ["check-dates"])
{ modeHelp = "check that transactions' date are monotonically increasing" { modeHelp = "check that transactions' date are monotonically increasing"
, modeGroupFlags = Group , modeGroupFlags = Group
{ groupNamed = { groupNamed =
[ ("Input",inputflags) [ ("Input",inputflags)
, ("Reporting",reportflags) , ("Reporting",reportflags)
, ("Misc",helpflags) , ("Misc",helpflags)
] ]
,groupUnnamed = [ ,groupUnnamed = [
flagNone ["strict"] (\opts -> setboolopt "strict" opts) "makes date comparing strict" flagNone ["strict"] (\opts -> setboolopt "strict" opts) "makes date comparing strict"
] ]
, groupHidden = [] , groupHidden = []
} }
} }
data FoldAcc a b = FoldAcc data FoldAcc a b = FoldAcc
{ fa_error :: Maybe a { 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 :: (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) = foldWhile fold acc (a:as) =
case fold a acc of case fold a acc of
acc@FoldAcc{fa_error=Just a} -> acc acc@FoldAcc{fa_error=Just _} -> acc
acc -> foldWhile fold acc as acc -> foldWhile fold acc as
checkTransactions :: (Transaction -> Transaction -> Bool) checkTransactions :: (Transaction -> Transaction -> Bool)
-> [Transaction] -> FoldAcc Transaction Transaction -> [Transaction] -> FoldAcc Transaction Transaction
checkTransactions compare ts = checkTransactions compare ts =
foldWhile fold FoldAcc{fa_error=Nothing, fa_previous=Nothing} ts foldWhile fold FoldAcc{fa_error=Nothing, fa_previous=Nothing} ts
where where
fold current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current} fold current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current}
fold current acc@FoldAcc{fa_previous=Just previous} = fold current acc@FoldAcc{fa_previous=Just previous} =
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}
main :: IO () main :: IO ()
main = do main = do
opts <- getCliOpts argsmode opts <- getCliOpts argsmode
withJournalDo opts $ withJournalDo opts $
\cliopts@CliOpts{rawopts_=opts,reportopts_=ropts} j -> do \CliOpts{rawopts_=opts,reportopts_=ropts} j -> do
d <- getCurrentDay d <- getCurrentDay
let ropts_ = ropts{flat_=True} let ropts_ = ropts{accountlistmode_=ALFlat}
let q = queryFromOpts d ropts_ let q = queryFromOpts d ropts_
let ts = filter (q `matchesTransaction`) $ let ts = filter (q `matchesTransaction`) $
jtxns $ journalSelectingAmountFromOpts ropts j jtxns $ journalSelectingAmountFromOpts ropts j
let strict = boolopt "strict" opts let strict = boolopt "strict" opts
let date = transactionDateFn ropts let date = transactionDateFn ropts
let compare a b = let compare a b =
if strict if strict
then date a < date b then date a < date b
else date a <= date b else date a <= date b
case checkTransactions compare ts of case checkTransactions compare ts of
FoldAcc{fa_previous=Nothing} -> putStrLn "ok (empty journal)" FoldAcc{fa_previous=Nothing} -> putStrLn "ok (empty journal)"
FoldAcc{fa_error=Nothing} -> putStrLn "ok" FoldAcc{fa_error=Nothing} -> putStrLn "ok"
FoldAcc{fa_error=Just error, fa_previous=Just previous} -> FoldAcc{fa_error=Just error, fa_previous=Just previous} ->
putStrLn $ printf ("ERROR: transaction out of%s date order" putStrLn $ printf ("ERROR: transaction out of%s date order"
++ "\nPrevious date: %s" ++ "\nPrevious date: %s"
++ "\nDate: %s" ++ "\nDate: %s"
++ "\nLocation: %s" ++ "\nLocation: %s"
++ "\nTransaction:\n\n%s") ++ "\nTransaction:\n\n%s")
(if strict then " STRICT" else "") (if strict then " STRICT" else "")
(show $ date previous) (show $ date previous)
(show $ date error) (show $ date error)
(show $ tsourcepos error) (show $ tsourcepos error)
(showTransactionUnelided error) (showTransactionUnelided error)