{-# LANGUAGE NoOverloadedStrings #-} -- prevent trouble if turned on in ghci
{-# LANGUAGE TemplateHaskell #-}

module Hledger.Cli.Commands.Checkdates (
  checkdatesmode
 ,checkdates
) where

import Hledger
import Hledger.Cli.CliOptions
import System.Console.CmdArgs.Explicit
import System.Exit
import Text.Printf

checkdatesmode :: Mode RawOpts
checkdatesmode :: Mode RawOpts
checkdatesmode = CommandDoc
-> [Flag RawOpts]
-> [(CommandDoc, [Flag RawOpts])]
-> [Flag RawOpts]
-> ([Arg RawOpts], Maybe (Arg RawOpts))
-> Mode RawOpts
hledgerCommandMode
  $(embedFileRelative "Hledger/Cli/Commands/Checkdates.txt")
  [[CommandDoc] -> (RawOpts -> RawOpts) -> CommandDoc -> Flag RawOpts
forall a. [CommandDoc] -> (a -> a) -> CommandDoc -> Flag a
flagNone ["strict"] (CommandDoc -> RawOpts -> RawOpts
setboolopt "strict") "makes date comparing strict"]
  [(CommandDoc, [Flag RawOpts])
generalflagsgroup1]
  [Flag RawOpts]
hiddenflags
  ([], Arg RawOpts -> Maybe (Arg RawOpts)
forall a. a -> Maybe a
Just (Arg RawOpts -> Maybe (Arg RawOpts))
-> Arg RawOpts -> Maybe (Arg RawOpts)
forall a b. (a -> b) -> a -> b
$ CommandDoc -> Arg RawOpts
argsFlag "[QUERY]")

checkdates :: CliOpts -> Journal -> IO ()
checkdates :: CliOpts -> Journal -> IO ()
checkdates CliOpts{rawopts_ :: CliOpts -> RawOpts
rawopts_=RawOpts
rawopts,reportopts_ :: CliOpts -> ReportOpts
reportopts_=ReportOpts
ropts} j :: Journal
j = do
  Day
d <- IO Day
getCurrentDay
  let ropts_ :: ReportOpts
ropts_ = ReportOpts
ropts{accountlistmode_ :: AccountListMode
accountlistmode_=AccountListMode
ALFlat}
  let q :: Query
q = Day -> ReportOpts -> Query
queryFromOpts Day
d ReportOpts
ropts_
  let ts :: [Transaction]
ts = (Transaction -> Bool) -> [Transaction] -> [Transaction]
forall a. (a -> Bool) -> [a] -> [a]
filter (Query
q Query -> Transaction -> Bool
`matchesTransaction`) ([Transaction] -> [Transaction]) -> [Transaction] -> [Transaction]
forall a b. (a -> b) -> a -> b
$
           Journal -> [Transaction]
jtxns (Journal -> [Transaction]) -> Journal -> [Transaction]
forall a b. (a -> b) -> a -> b
$ ReportOpts -> Journal -> Journal
journalSelectingAmountFromOpts ReportOpts
ropts Journal
j
  let strict :: Bool
strict = CommandDoc -> RawOpts -> Bool
boolopt "strict" RawOpts
rawopts
  let date :: Transaction -> Day
date = ReportOpts -> Transaction -> Day
transactionDateFn ReportOpts
ropts
  let compare :: Transaction -> Transaction -> Bool
compare a :: Transaction
a b :: Transaction
b =
        if Bool
strict
        then Transaction -> Day
date Transaction
a Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
<  Transaction -> Day
date Transaction
b
        else Transaction -> Day
date Transaction
a Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
<= Transaction -> Day
date Transaction
b
  case (Transaction -> Transaction -> Bool)
-> [Transaction] -> FoldAcc Transaction Transaction
checkTransactions Transaction -> Transaction -> Bool
compare [Transaction]
ts of
   FoldAcc{fa_previous :: forall a b. FoldAcc a b -> Maybe b
fa_previous=Maybe Transaction
Nothing} -> CommandDoc -> IO ()
putStrLn "ok (empty journal)" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess
   FoldAcc{fa_error :: forall a b. FoldAcc a b -> Maybe a
fa_error=Maybe Transaction
Nothing}    -> CommandDoc -> IO ()
putStrLn "ok" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess
   FoldAcc{fa_error :: forall a b. FoldAcc a b -> Maybe a
fa_error=Just error :: Transaction
error, fa_previous :: forall a b. FoldAcc a b -> Maybe b
fa_previous=Just previous :: Transaction
previous} ->
    (CommandDoc -> IO ()
putStrLn (CommandDoc -> IO ()) -> CommandDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandDoc
-> CommandDoc
-> CommandDoc
-> CommandDoc
-> CommandDoc
-> CommandDoc
-> CommandDoc
forall r. PrintfType r => CommandDoc -> r
printf ("ERROR: transaction out of%s date order"
     CommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++ "\nPrevious date: %s"
     CommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++ "\nDate: %s"
     CommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++ "\nLocation: %s"
     CommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++ "\nTransaction:\n\n%s")
     (if Bool
strict then " STRICT" else "")
     (Day -> CommandDoc
forall a. Show a => a -> CommandDoc
show (Day -> CommandDoc) -> Day -> CommandDoc
forall a b. (a -> b) -> a -> b
$ Transaction -> Day
date Transaction
previous)
     (Day -> CommandDoc
forall a. Show a => a -> CommandDoc
show (Day -> CommandDoc) -> Day -> CommandDoc
forall a b. (a -> b) -> a -> b
$ Transaction -> Day
date Transaction
error)
     (GenericSourcePos -> CommandDoc
forall a. Show a => a -> CommandDoc
show (GenericSourcePos -> CommandDoc) -> GenericSourcePos -> CommandDoc
forall a b. (a -> b) -> a -> b
$ Transaction -> GenericSourcePos
tsourcepos Transaction
error)
     (Transaction -> CommandDoc
showTransaction Transaction
error)) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure

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

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

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