--- /dev/null
+#!/usr/bin/env runhaskell
+{-|
+hledger-check-dates [--strict] [--date2] [-f JOURNALFILE]
+
+Check that transactions' date are monotonically increasing.
+Reads the default or specified journal.
+|-}
+
+import Hledger
+import Hledger.Cli
+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 = []
+ }
+ }
+
+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 fold acc [] = acc
+foldWhile fold acc (a:as) =
+ case fold a acc of
+ acc@FoldAcc{fa_error=Just a} -> 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}
+
+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)