Ordereddates.hs

module Hledger.Data.JournalChecks.Ordereddates (
  journalCheckOrdereddates
)
where

import Control.Monad (forM)
import Data.List (groupBy)
import Text.Printf (printf)
import qualified Data.Text as T (pack, unlines)

import Hledger.Data.Errors (makeTransactionErrorExcerpt)
import Hledger.Data.Transaction (transactionFile)
import Hledger.Data.Types
import Hledger.Utils (textChomp)

journalCheckOrdereddates :: Journal -> Either String ()
journalCheckOrdereddates j = do
  let
    -- we check date ordering within each file, not across files
    -- note, relying on txns always being sorted by file here
    txnsbyfile = groupBy (\t1 t2 -> transactionFile t1 == transactionFile t2) $ jtxns j
    compare' a b = tdate a <= tdate b
  (const $ Right ()) =<< (forM txnsbyfile $ \ts ->
    case checkTransactions compare' ts of
      FoldAcc{fa_previous=Nothing} -> Right ()
      FoldAcc{fa_error=Nothing}    -> Right ()
      FoldAcc{fa_error=Just t, fa_previous=Just tprev} -> Left $ printf
        ("%s:%d:\n%s\nOrdered dates checking is enabled, and this transaction's\n"
          ++ "date (%s) is out of order with the previous transaction.\n"
          ++ "Consider moving this entry into date order, or adjusting its date.")
        f l ex (show $ tdate t)
        where
          (_,_,_,ex1) = makeTransactionErrorExcerpt tprev (const Nothing)
          (f,l,_,ex2) = makeTransactionErrorExcerpt t finderrcols
          -- separate the two excerpts by a space-beginning line to help flycheck-hledger parse them
          ex = T.unlines [textChomp ex1, T.pack " ", textChomp ex2]
          finderrcols _t = Just (1, Just 10)
    )

data FoldAcc a b = FoldAcc
 { fa_error    :: Maybe a
 , fa_previous :: Maybe b
 }

checkTransactions :: (Transaction -> Transaction -> Bool)
  -> [Transaction] -> FoldAcc Transaction Transaction
checkTransactions compare' = foldWhile f FoldAcc{fa_error=Nothing, fa_previous=Nothing}
  where
    f current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current}
    f current acc@FoldAcc{fa_previous=Just previous} =
      if compare' previous current
      then acc{fa_previous=Just current}
      else acc{fa_error=Just current}

foldWhile :: (a -> FoldAcc a b -> FoldAcc a b) -> FoldAcc a b -> [a] -> FoldAcc a b
foldWhile _ acc [] = acc
foldWhile fold acc (a:as) =
  case fold a acc of
   acc'@FoldAcc{fa_error=Just _} -> acc'
   acc' -> foldWhile fold acc' as