extra: add hledger-check-dates

extra/hledger-check-dates.hs

@@ -0,0 +1,81 @@
+#!/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)