Ajout : rangement.

[tool/hledger.git] / script / hledger-check-dates.hs

diff --git a/script/hledger-check-dates.hs b/script/hledger-check-dates.hs
new file mode 100755 (executable)
index 0000000..8c47351
--- /dev/null
+++ b/script/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)