module Penny.Wheat where
import Control.Applicative
import Control.Monad (when)
import Data.List (find, isPrefixOf)
import Data.Maybe (mapMaybe, catMaybes)
import Data.Monoid ((<>), mempty)
import qualified Penny.Copper as Cop
import qualified Penny.Copper.Parsec as CP
import qualified Penny.Lincoln as L
import qualified Data.Text as X
import qualified Data.Time as Time
import qualified Text.Parsec as Parsec
import qualified System.Exit as Exit
import qualified Penny.Shield as S
import qualified Penny.Steel.TestTree as TT
import qualified Penny.Steel.Pdct as Pe
import qualified Penny.Steel.Chunk as C
import qualified Options.Applicative as OA
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
type ColorToFile = Bool
type BaseTime = Time.UTCTime
type ProgName = String
data WheatConf = WheatConf
{ briefDescription :: String
, moreHelp :: [String]
, passVerbosity :: TT.PassVerbosity
, failVerbosity :: TT.FailVerbosity
, indentAmt :: Pe.IndentAmt
, colorToFile :: ColorToFile
, tests :: [BaseTime -> TT.TestTree L.PostFam]
, baseTime :: BaseTime
}
parseAbbrev :: [(String, a)] -> String -> Either OA.ParseError a
parseAbbrev ls str = case find (\(s, _) -> s == str) ls of
Nothing -> lookupAbbrev
Just (_, a) -> Right a
where
lookupAbbrev = case filter ((str `isPrefixOf`) . fst) ls of
(_, a):[] -> Right a
_ -> Left (OA.ErrorMsg ("invalid argument: " ++ str))
parseVerbosity :: String -> Either OA.ParseError TT.Verbosity
parseVerbosity = parseAbbrev
[ ("silent", TT.Silent)
, ("minimal", TT.PassFail)
, ("false", TT.FalseSubjects)
, ("true", TT.TrueSubjects)
, ("discarded", TT.DiscardedSubjects)
, ("all", TT.DiscardedPredicates)
]
parseColorToFile :: String -> Either OA.ParseError ColorToFile
parseColorToFile = parseAbbrev [ ("no", False), ("yes", True) ]
parseBaseTime :: String -> Either OA.ParseError BaseTime
parseBaseTime s = case Parsec.parse CP.dateTime "" (X.pack s) of
Left e -> Left (OA.ErrorMsg $ "could not parse date: " ++ show e)
Right g -> Right . L.toUTC $ g
data Parsed = Parsed
{ p_passVerbosity :: TT.PassVerbosity
, p_failVerbosity :: TT.FailVerbosity
, p_indentAmt :: Pe.IndentAmt
, p_colorToFile :: ColorToFile
, p_baseTime :: BaseTime
, p_ledgers :: [String]
}
parseOpts :: WheatConf -> OA.Parser Parsed
parseOpts wc
= Parsed
<$> ( OA.nullOption
( OA.long "pass-verbosity"
<> OA.short 'p'
<> OA.reader parseVerbosity )
<|> pure (passVerbosity wc) )
<*> ( OA.nullOption
( OA.long "fail-verbosity"
<> OA.short 'f'
<> OA.reader parseVerbosity )
<|> pure (failVerbosity wc) )
<*> ( OA.option
( OA.long "indentation"
<> OA.short 'i' )
<|> pure (indentAmt wc) )
<*> ( OA.nullOption
( OA.long "color-to-file"
<> OA.reader parseColorToFile )
<|> pure (colorToFile wc))
<*> ( OA.nullOption
( OA.long "base-date"
<> OA.reader parseBaseTime )
<|> pure (baseTime wc) )
<*> ( many (OA.argument OA.str mempty))
main :: (S.Runtime -> WheatConf) -> IO ()
main getWc = do
rt <- S.runtime
let inf = OA.fullDesc
wc = getWc rt
psd <- OA.execParser (OA.info (parseOpts wc) inf)
let term = if p_colorToFile psd || (S.output rt == S.IsTTY)
then S.termFromEnv rt
else S.autoTerm rt
pfs <- getItems (p_ledgers psd)
let tts = zipWith ($) (tests wc) (repeat (p_baseTime psd))
doEval = TT.evalTestTree (p_indentAmt psd) 0 (p_passVerbosity psd)
(p_failVerbosity psd) pfs
eithers = concatMap doEval tts
passes <- mapM (showEitherChunk (C.printChunks term)) eithers
when (not . and . catMaybes $ passes) Exit.exitFailure
showEitherChunk
:: ([C.Chunk] -> IO ())
-> Either C.Chunk (TT.Pass, [C.Chunk])
-> IO (Maybe TT.Pass)
showEitherChunk f ei = case ei of
Left ck -> f [ck] >> return Nothing
Right (p, cs) -> f cs >> return (Just p)
getItems :: [String] -> IO [L.PostFam]
getItems ss = fmap f $ Cop.open ss
where
f = concatMap L.postFam . mapMaybe toTxn . Cop.unLedger
toTxn i = case i of { Cop.Transaction x -> Just x; _ -> Nothing }
eachPostingMustBeTrue
:: TT.Name
-> Pe.Pdct L.PostFam
-> TT.TestTree L.PostFam
eachPostingMustBeTrue n = TT.eachSubjectMustBeTrue n L.display
atLeastNPostings
:: Int
-> TT.Name
-> Pe.Pdct L.PostFam
-> TT.TestTree L.PostFam
atLeastNPostings i n = TT.seriesAtLeastN n L.display i