module Penny.Wheat
(
WheatConf(..)
, eachPostingMustBeTrue
, atLeastNPostings
, futureFirstsOfTheMonth
, main
) where
import Data.Either (partitionEithers)
import Data.Maybe (mapMaybe)
import qualified Penny.Copper as Cop
import qualified Penny.Copper.Parsec as CP
import qualified Penny.Lincoln as L
import qualified Penny.Liberty as Ly
import qualified Data.Text as X
import qualified Data.Time as Time
import qualified Text.Matchers as M
import qualified Text.Parsec as Parsec
import qualified System.Exit as Exit
import qualified System.IO as IO
import qualified Penny.Shield as S
import qualified Data.Sums as Su
import qualified Data.Version as V
import qualified Data.Prednote.Test as TT
import qualified Data.Prednote.Pdct as Pe
import qualified System.Console.Rainbow as Rb
import qualified System.Console.MultiArg as MA
import System.Locale (defaultTimeLocale)
futureFirstsOfTheMonth :: Time.Day -> [Time.Day]
futureFirstsOfTheMonth d = iterate (Time.addGregorianMonthsClip 1) d1
where
d1 = Time.fromGregorian yr mo 1
(yr, mo, _) = Time.toGregorian $ Time.addGregorianMonthsClip 1 d
data WheatConf = WheatConf
{ briefDescription :: String
, moreHelp :: [String]
, tests :: [Time.UTCTime -> TT.Test L.Posting]
, indentAmt :: Pe.IndentAmt
, verbosity :: Maybe TT.TestVerbosity
, testPred :: TT.Name -> Bool
, stopOnFail :: Bool
, colorToFile :: Bool
, baseTime :: Time.UTCTime
, formatQty :: [Cop.LedgerItem] -> L.Amount L.Qty -> X.Text
}
parseBaseTime :: String -> Either MA.InputError Time.UTCTime
parseBaseTime s = case Parsec.parse CP.dateTime "" (X.pack s) of
Left e -> Left (MA.ErrorMsg $ "could not parse date: " ++ show e)
Right g -> return . L.toUTC $ g
parseRegexp :: String -> Either MA.InputError (TT.Name -> Bool)
parseRegexp s = case M.pcre M.Sensitive (X.pack s) of
Left e -> Left . MA.ErrorMsg $
"could not parse regular expression: " ++ X.unpack e
Right m -> return . M.match $ m
allOpts :: [MA.OptSpec (WheatConf -> WheatConf)]
allOpts =
[ MA.OptSpec ["indentation"] "i"
(fmap (\i p -> p { indentAmt = i }) (MA.OneArg MA.reader))
, MA.OptSpec ["test-regexp"] "t"
(fmap (\f p -> p { testPred = f }) (MA.OneArg parseRegexp))
, MA.OptSpec ["stop-on-failure"] ""
( MA.NoArg (\p -> p { stopOnFail
= not (stopOnFail p) }))
, MA.OptSpec ["color-to-file"] ""
( MA.NoArg (\p -> p { colorToFile
= not (colorToFile p) }))
, MA.OptSpec ["base-date"] ""
(fmap (\d p -> p { baseTime = d }) (MA.OneArg parseBaseTime))
]
parseArgs :: V.Version -> WheatConf -> IO (WheatConf, [String])
parseArgs ver c = do
parsed <- MA.simpleHelpVersion (help c) (Ly.version ver)
(map (fmap Right) allOpts) MA.Intersperse
(return . Left)
let (args, opts) = partitionEithers parsed
fn = foldl (flip (.)) id opts
c' = fn c
return (c', args)
main
:: V.Version
-> (S.Runtime -> WheatConf) -> IO ()
main ver getWc = do
rt <- S.runtime
(conf, args) <- parseArgs ver (getWc rt)
term <- Rb.smartTermFromEnv (colorToFile conf) IO.stdout
items <- Cop.open args
let pstgs = getItems items
formatter = formatQty conf items
let tsts = filter ((testPred conf) . TT.testName)
. map ($ (L.toUTC . S.currentTime $ rt))
. tests
$ conf
bs <- mapM (runTest formatter conf pstgs term) tsts
if and bs
then Exit.exitSuccess
else Exit.exitFailure
runTest
:: (L.Amount L.Qty -> X.Text)
-> WheatConf
-> [L.Posting]
-> Rb.Term
-> TT.Test L.Posting
-> IO Bool
runTest fmt c ps term test = do
let rslt = TT.evalTest test ps
cks = TT.showResult (indentAmt c) (L.display fmt)
(verbosity c) rslt
Rb.putChunks term cks
if stopOnFail c && not (TT.resultPass rslt)
then Exit.exitFailure
else return (TT.resultPass rslt)
getItems :: [Cop.LedgerItem] -> [L.Posting]
getItems
= concatMap L.transactionToPostings
. mapMaybe ( let cn = const Nothing
in Su.caseS4 Just cn cn cn)
eachPostingMustBeTrue
:: TT.Name
-> Pe.Pdct L.Posting
-> TT.Test L.Posting
eachPostingMustBeTrue n pd = TT.eachSubjectMustBeTrue pd n
atLeastNPostings
:: Int
-> TT.Name
-> Pe.Pdct L.Posting
-> TT.Test L.Posting
atLeastNPostings i n pd = TT.nSubjectsMustBeTrue pd n i
help
:: WheatConf
-> String
-> String
help wc pn = unlines
[ "usage: " ++ pn ++ " [options] [FILE...]"
, ""
, briefDescription wc
, ""
, "Options:"
, " -i, --indentation AMT"
, " Indent each level by this many spaces"
, " " ++ dflt (show . indentAmt $ wc)
, " -t, --test-regexp REGEXP"
, " Run only tests whose name matches the given"
, " Perl-compatible regular expression"
, " (overrides the compiled-in default)"
, " --stop-on-failure"
, " Stop running tests after a single test fails"
, " " ++ dflt (show . stopOnFail $ wc)
, " --color-to-file"
, " Use color even when standard output is not a terminal"
, " " ++ dflt (show . colorToFile $ wc)
, " --base-date DATE"
, " Use this date as a basis for checks"
, " " ++ dflt ( Time.formatTime defaultTimeLocale "%c"
. baseTime $ wc)
, ""
]
++ unlines (moreHelp wc)
dflt :: String -> String
dflt s = "(default: " ++ s ++ ")"