1 #!/usr/bin/env runhaskell
3 hledger-check-dates [--strict] [--date2] [-f JOURNALFILE]
5 Check that transactions' date are monotonically increasing.
6 Reads the default or specified journal.
13 argsmode :: Mode RawOpts
14 argsmode = (defCommandMode ["check-dates"])
15 { modeHelp = "check that transactions' date are monotonically increasing"
16 , modeGroupFlags = Group
18 [ ("Input",inputflags)
19 , ("Reporting",reportflags)
23 flagNone ["strict"] (\opts -> setboolopt "strict" opts) "makes date comparing strict"
29 data FoldAcc a b = FoldAcc
31 , fa_previous :: Maybe b
34 foldWhile :: (a -> FoldAcc a b -> FoldAcc a b) -> FoldAcc a b -> [a] -> FoldAcc a b
35 foldWhile fold acc [] = acc
36 foldWhile fold acc (a:as) =
38 acc@FoldAcc{fa_error=Just a} -> acc
39 acc -> foldWhile fold acc as
41 checkTransactions :: (Transaction -> Transaction -> Bool)
42 -> [Transaction] -> FoldAcc Transaction Transaction
43 checkTransactions compare ts =
44 foldWhile fold FoldAcc{fa_error=Nothing, fa_previous=Nothing} ts
46 fold current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current}
47 fold current acc@FoldAcc{fa_previous=Just previous} =
48 if compare previous current
49 then acc{fa_previous=Just current}
50 else acc{fa_error=Just current}
54 opts <- getCliOpts argsmode
56 \cliopts@CliOpts{rawopts_=opts,reportopts_=ropts} j -> do
58 let ropts_ = ropts{flat_=True}
59 let q = queryFromOpts d ropts_
60 let ts = filter (q `matchesTransaction`) $
61 jtxns $ journalSelectingAmountFromOpts ropts j
62 let strict = boolopt "strict" opts
63 let date = transactionDateFn ropts
68 case checkTransactions compare ts of
69 FoldAcc{fa_previous=Nothing} -> putStrLn "ok (empty journal)"
70 FoldAcc{fa_error=Nothing} -> putStrLn "ok"
71 FoldAcc{fa_error=Just error, fa_previous=Just previous} ->
72 putStrLn $ printf ("ERROR: transaction out of%s date order"
73 ++ "\nPrevious date: %s"
76 ++ "\nTransaction:\n\n%s")
77 (if strict then " STRICT" else "")
78 (show $ date previous)
80 (show $ tsourcepos error)
81 (showTransactionUnelided error)