script/hledger-check-dates.hs

   1 #!/usr/bin/env runhaskell
   2 {-|
   3 hledger-check-dates [--strict] [--date2] [-f JOURNALFILE]
   4
   5 Check that transactions' date are monotonically increasing.
   6 Reads the default or specified journal.
   7 |-}
   8
   9 import Hledger
  10 import Hledger.Cli
  11 import Text.Printf
  12
  13 argsmode :: Mode RawOpts
  14 argsmode = (defCommandMode ["check-dates"])
  15         { modeHelp = "check that transactions' date are monotonically increasing"
  16         , modeGroupFlags = Group
  17                 { groupNamed =
  18                         [ ("Input",inputflags)
  19                         , ("Reporting",reportflags)
  20                         , ("Misc",helpflags)
  21                         ]
  22                 ,groupUnnamed = [
  23                         flagNone ["strict"] (\opts -> setboolopt "strict" opts) "makes date comparing strict"
  24                  ]
  25                 , groupHidden = []
  26                 }
  27         }
  28
  29 data FoldAcc a b = FoldAcc
  30  { fa_error    :: Maybe a
  31  , fa_previous :: Maybe b
  32  }
  33
  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) =
  37         case fold a acc of
  38          acc@FoldAcc{fa_error=Just a} -> acc
  39          acc -> foldWhile fold acc as
  40
  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
  45         where
  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}
  51
  52 main :: IO ()
  53 main = do
  54         opts <- getCliOpts argsmode
  55         withJournalDo opts $
  56          \cliopts@CliOpts{rawopts_=opts,reportopts_=ropts} j -> do
  57                 d <- getCurrentDay
  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
  64                 let compare a b =
  65                         if strict
  66                         then date a <  date b
  67                         else date a <= date b
  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"
  74                          ++ "\nDate: %s"
  75                          ++ "\nLocation: %s"
  76                          ++ "\nTransaction:\n\n%s")
  77                          (if strict then " STRICT" else "")
  78                          (show $ date previous)
  79                          (show $ date error)
  80                          (show $ tsourcepos error)
  81                          (showTransactionUnelided error)