{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Hledger.Cli.Commands.Check (
  checkmode
 ,check
) where

import Data.Char (toLower,toUpper)
import Data.Either (partitionEithers)
import Data.List (isPrefixOf, find)
import Control.Monad (forM_)
import System.Console.CmdArgs.Explicit
import System.Exit (exitFailure)
import System.IO (stderr, hPutStrLn)

import Hledger
import Hledger.Cli.CliOptions
import Hledger.Cli.Commands.Check.Ordereddates (journalCheckOrdereddates)
import Hledger.Cli.Commands.Check.Uniqueleafnames (journalCheckUniqueleafnames)

checkmode :: Mode RawOpts
checkmode :: Mode RawOpts
checkmode = CommandDoc
-> [Flag RawOpts]
-> [(CommandDoc, [Flag RawOpts])]
-> [Flag RawOpts]
-> ([Arg RawOpts], Maybe (Arg RawOpts))
-> Mode RawOpts
hledgerCommandMode
  $(embedFileRelative "Hledger/Cli/Commands/Check.txt")
  []
  [(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 CommandDoc
"[CHECKS]")

check :: CliOpts -> Journal -> IO ()
check :: CliOpts -> Journal -> IO ()
check copts :: CliOpts
copts@CliOpts{RawOpts
rawopts_ :: CliOpts -> RawOpts
rawopts_ :: RawOpts
rawopts_} Journal
j = do
  let 
    args :: [CommandDoc]
args = CommandDoc -> RawOpts -> [CommandDoc]
listofstringopt CommandDoc
"args" RawOpts
rawopts_
    -- reset the report spec that was generated by argsToCliOpts,
    -- since we are not using arguments as a query in the usual way
    copts' :: CliOpts
copts' = (ReportOpts -> ReportOpts) -> CliOpts -> CliOpts
cliOptsUpdateReportSpecWith (\ReportOpts
ropts -> ReportOpts
ropts{querystring_ :: [Text]
querystring_=[]}) CliOpts
copts

  case [Either CommandDoc (Check, [CommandDoc])]
-> ([CommandDoc], [(Check, [CommandDoc])])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((CommandDoc -> Either CommandDoc (Check, [CommandDoc]))
-> [CommandDoc] -> [Either CommandDoc (Check, [CommandDoc])]
forall a b. (a -> b) -> [a] -> [b]
map CommandDoc -> Either CommandDoc (Check, [CommandDoc])
parseCheckArgument [CommandDoc]
args) of
    (unknowns :: [CommandDoc]
unknowns@(CommandDoc
_:[CommandDoc]
_), [(Check, [CommandDoc])]
_) -> CommandDoc -> IO ()
forall a. CommandDoc -> a
error' (CommandDoc -> IO ()) -> CommandDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandDoc
"These checks are unknown: "CommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++[CommandDoc] -> CommandDoc
unwords [CommandDoc]
unknowns
    ([], [(Check, [CommandDoc])]
checks) -> [(Check, [CommandDoc])]
-> ((Check, [CommandDoc]) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Check, [CommandDoc])]
checks (((Check, [CommandDoc]) -> IO ()) -> IO ())
-> ((Check, [CommandDoc]) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ CliOpts -> Journal -> (Check, [CommandDoc]) -> IO ()
runCheck CliOpts
copts' Journal
j
      
-- | Regenerate this CliOpts' report specification, after updating its
-- underlying report options with the given update function.
-- This can raise an error if there is a problem eg due to missing or
-- unparseable options data. See also updateReportSpecFromOpts.
cliOptsUpdateReportSpecWith :: (ReportOpts -> ReportOpts) -> CliOpts -> CliOpts
cliOptsUpdateReportSpecWith :: (ReportOpts -> ReportOpts) -> CliOpts -> CliOpts
cliOptsUpdateReportSpecWith ReportOpts -> ReportOpts
roptsupdate copts :: CliOpts
copts@CliOpts{ReportSpec
reportspec_ :: CliOpts -> ReportSpec
reportspec_ :: ReportSpec
reportspec_} =
  case (ReportOpts -> ReportOpts)
-> ReportSpec -> Either CommandDoc ReportSpec
updateReportSpecWith ReportOpts -> ReportOpts
roptsupdate ReportSpec
reportspec_ of
    Left CommandDoc
e   -> CommandDoc -> CliOpts
forall a. CommandDoc -> a
error' CommandDoc
e  -- PARTIAL:
    Right ReportSpec
rs -> CliOpts
copts{reportspec_ :: ReportSpec
reportspec_=ReportSpec
rs}

-- | A type of error check that we can perform on the data.
-- Some of these imply other checks that are done first,
-- eg currently Parseable and Balancedwithautoconversion are always done,
-- and Assertions are always done unless -I is in effect.
data Check =
  -- done always
    Parseable
  | Balancedwithautoconversion
  -- done always unless -I is used
  | Assertions
  -- done when -s is used, or on demand by check
  | Accounts
  | Commodities
  | Balancednoautoconversion
  -- done on demand by check
  | Ordereddates
  | Payees
  | Uniqueleafnames
  deriving (ReadPrec [Check]
ReadPrec Check
Int -> ReadS Check
ReadS [Check]
(Int -> ReadS Check)
-> ReadS [Check]
-> ReadPrec Check
-> ReadPrec [Check]
-> Read Check
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Check]
$creadListPrec :: ReadPrec [Check]
readPrec :: ReadPrec Check
$creadPrec :: ReadPrec Check
readList :: ReadS [Check]
$creadList :: ReadS [Check]
readsPrec :: Int -> ReadS Check
$creadsPrec :: Int -> ReadS Check
Read,Int -> Check -> CommandDoc -> CommandDoc
[Check] -> CommandDoc -> CommandDoc
Check -> CommandDoc
(Int -> Check -> CommandDoc -> CommandDoc)
-> (Check -> CommandDoc)
-> ([Check] -> CommandDoc -> CommandDoc)
-> Show Check
forall a.
(Int -> a -> CommandDoc -> CommandDoc)
-> (a -> CommandDoc) -> ([a] -> CommandDoc -> CommandDoc) -> Show a
showList :: [Check] -> CommandDoc -> CommandDoc
$cshowList :: [Check] -> CommandDoc -> CommandDoc
show :: Check -> CommandDoc
$cshow :: Check -> CommandDoc
showsPrec :: Int -> Check -> CommandDoc -> CommandDoc
$cshowsPrec :: Int -> Check -> CommandDoc -> CommandDoc
Show,Check -> Check -> Bool
(Check -> Check -> Bool) -> (Check -> Check -> Bool) -> Eq Check
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Check -> Check -> Bool
$c/= :: Check -> Check -> Bool
== :: Check -> Check -> Bool
$c== :: Check -> Check -> Bool
Eq,Int -> Check
Check -> Int
Check -> [Check]
Check -> Check
Check -> Check -> [Check]
Check -> Check -> Check -> [Check]
(Check -> Check)
-> (Check -> Check)
-> (Int -> Check)
-> (Check -> Int)
-> (Check -> [Check])
-> (Check -> Check -> [Check])
-> (Check -> Check -> [Check])
-> (Check -> Check -> Check -> [Check])
-> Enum Check
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Check -> Check -> Check -> [Check]
$cenumFromThenTo :: Check -> Check -> Check -> [Check]
enumFromTo :: Check -> Check -> [Check]
$cenumFromTo :: Check -> Check -> [Check]
enumFromThen :: Check -> Check -> [Check]
$cenumFromThen :: Check -> Check -> [Check]
enumFrom :: Check -> [Check]
$cenumFrom :: Check -> [Check]
fromEnum :: Check -> Int
$cfromEnum :: Check -> Int
toEnum :: Int -> Check
$ctoEnum :: Int -> Check
pred :: Check -> Check
$cpred :: Check -> Check
succ :: Check -> Check
$csucc :: Check -> Check
Enum,Check
Check -> Check -> Bounded Check
forall a. a -> a -> Bounded a
maxBound :: Check
$cmaxBound :: Check
minBound :: Check
$cminBound :: Check
Bounded)

-- | Parse the name (or a name prefix) of an error check, or return the name unparsed.
-- Check names are conventionally all lower case, but this parses case insensitively.
parseCheck :: String -> Either String Check
parseCheck :: CommandDoc -> Either CommandDoc Check
parseCheck CommandDoc
s = 
  Either CommandDoc Check
-> (CommandDoc -> Either CommandDoc Check)
-> Maybe CommandDoc
-> Either CommandDoc Check
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CommandDoc -> Either CommandDoc Check
forall a b. a -> Either a b
Left CommandDoc
s) (Check -> Either CommandDoc Check
forall a b. b -> Either a b
Right (Check -> Either CommandDoc Check)
-> (CommandDoc -> Check) -> CommandDoc -> Either CommandDoc Check
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandDoc -> Check
forall a. Read a => CommandDoc -> a
read) (Maybe CommandDoc -> Either CommandDoc Check)
-> Maybe CommandDoc -> Either CommandDoc Check
forall a b. (a -> b) -> a -> b
$  -- PARTIAL: read should not fail here
  (CommandDoc -> Bool) -> [CommandDoc] -> Maybe CommandDoc
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (CommandDoc
s' CommandDoc -> CommandDoc -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([CommandDoc] -> Maybe CommandDoc)
-> [CommandDoc] -> Maybe CommandDoc
forall a b. (a -> b) -> a -> b
$ [CommandDoc]
checknames
  where
    s' :: CommandDoc
s' = CommandDoc -> CommandDoc
capitalise (CommandDoc -> CommandDoc) -> CommandDoc -> CommandDoc
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> CommandDoc -> CommandDoc
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower CommandDoc
s
    checknames :: [CommandDoc]
checknames = (Check -> CommandDoc) -> [Check] -> [CommandDoc]
forall a b. (a -> b) -> [a] -> [b]
map Check -> CommandDoc
forall a. Show a => a -> CommandDoc
show [Check
forall a. Bounded a => a
minBound..Check
forall a. Bounded a => a
maxBound::Check]

capitalise :: String -> String
capitalise :: CommandDoc -> CommandDoc
capitalise (Char
c:CommandDoc
cs) = Char -> Char
toUpper Char
c Char -> CommandDoc -> CommandDoc
forall a. a -> [a] -> [a]
: CommandDoc
cs
capitalise CommandDoc
s = CommandDoc
s

-- | Parse a check argument: a string which is the lower-case name of an error check,
-- or a prefix thereof, followed by zero or more space-separated arguments for that check.
parseCheckArgument :: String -> Either String (Check,[String])
parseCheckArgument :: CommandDoc -> Either CommandDoc (Check, [CommandDoc])
parseCheckArgument CommandDoc
s =
  CommandDoc
-> Either CommandDoc (Check, [CommandDoc])
-> Either CommandDoc (Check, [CommandDoc])
forall a. Show a => CommandDoc -> a -> a
dbg3 CommandDoc
"check argument" (Either CommandDoc (Check, [CommandDoc])
 -> Either CommandDoc (Check, [CommandDoc]))
-> Either CommandDoc (Check, [CommandDoc])
-> Either CommandDoc (Check, [CommandDoc])
forall a b. (a -> b) -> a -> b
$
  ((,[CommandDoc]
checkargs)) (Check -> (Check, [CommandDoc]))
-> Either CommandDoc Check
-> Either CommandDoc (Check, [CommandDoc])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CommandDoc -> Either CommandDoc Check
parseCheck CommandDoc
checkname
  where
    (CommandDoc
checkname:[CommandDoc]
checkargs) = CommandDoc -> [CommandDoc]
words' CommandDoc
s

-- XXX do all of these print on stderr ?
-- | Run the named error check, possibly with some arguments, 
-- on this journal with these options.
runCheck :: CliOpts -> Journal -> (Check,[String]) -> IO ()
runCheck :: CliOpts -> Journal -> (Check, [CommandDoc]) -> IO ()
runCheck copts :: CliOpts
copts@CliOpts{RawOpts
rawopts_ :: RawOpts
rawopts_ :: CliOpts -> RawOpts
rawopts_} Journal
j (Check
check,[CommandDoc]
args) = do
  let
    -- XXX drop this ?
    -- Hack: append the provided args to the raw opts, for checks 
    -- which can use them (just journalCheckOrdereddates rignt now
    -- which has some flags from the old checkdates command). 
    -- Does not bother to regenerate the derived data (ReportOpts, ReportSpec..), 
    -- so those may be inconsistent.
    copts' :: CliOpts
copts' = CliOpts
copts{rawopts_ :: RawOpts
rawopts_=[(CommandDoc, CommandDoc)] -> RawOpts -> RawOpts
appendopts ((CommandDoc -> (CommandDoc, CommandDoc))
-> [CommandDoc] -> [(CommandDoc, CommandDoc)]
forall a b. (a -> b) -> [a] -> [b]
map (,CommandDoc
"") [CommandDoc]
args) RawOpts
rawopts_}

    results :: Either CommandDoc ()
results = case Check
check of
      Check
Accounts        -> Journal -> Either CommandDoc ()
journalCheckAccountsDeclared Journal
j
      Check
Commodities     -> Journal -> Either CommandDoc ()
journalCheckCommoditiesDeclared Journal
j
      Check
Ordereddates    -> CliOpts -> Journal -> Either CommandDoc ()
journalCheckOrdereddates CliOpts
copts' Journal
j
      Check
Payees          -> Journal -> Either CommandDoc ()
journalCheckPayeesDeclared Journal
j
      Check
Uniqueleafnames -> Journal -> Either CommandDoc ()
journalCheckUniqueleafnames Journal
j
      -- the other checks have been done earlier during withJournalDo
      Check
_               -> () -> Either CommandDoc ()
forall a b. b -> Either a b
Right ()

  case Either CommandDoc ()
results of
    Right () -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Left CommandDoc
err -> Handle -> CommandDoc -> IO ()
hPutStrLn Handle
stderr (CommandDoc
"Error: "CommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++CommandDoc
err) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure