diff --git a/lib/Penny/Cabin/Posts.hs b/lib/Penny/Cabin/Posts.hs --- a/lib/Penny/Cabin/Posts.hs +++ b/lib/Penny/Cabin/Posts.hs @@ -58,7 +58,6 @@ import qualified Control.Monad.Exception.Synchronous as Ex import Data.List.Split (chunksOf) import qualified Data.Either as Ei -import Data.Monoid ((<>)) import qualified Data.Text as X import qualified Penny.Cabin.Interface as I import qualified Penny.Cabin.Options as CO @@ -183,27 +182,16 @@ showVerboseFilter :: P.VerboseFilter - -> Pe.Pdct ((Ly.LibertyMeta, L.Posting)) + -> Pe.Pdct (Ly.LibertyMeta, L.Posting) -> [(Ly.LibertyMeta, L.Posting)] -> [Rb.Chunk] showVerboseFilter (P.VerboseFilter b) pdct bs = if not b then [] else info : blankLine : (chks ++ [blankLine]) where - pdcts = map (makeLabeledPdct pdct) bs - chks = concat . map snd $ zipWith doEval bs pdcts - doEval subj pd = Pe.evaluate indentAmt False subj 0 pd + chks = + fst + $ Pe.verboseFilter (L.display . snd) indentAmt False pdct bs info = "Postings report filter:\n" - --- | Creates a Pdct and prepends a one-line description of the PostFam --- to the Pdct's label so it can be easily identified in the output. -makeLabeledPdct - :: Pe.Pdct ((Ly.LibertyMeta, L.Posting)) - -> (Ly.LibertyMeta, L.Posting) - -> Pe.Pdct ((Ly.LibertyMeta, L.Posting)) -makeLabeledPdct pd box = Pe.rename f pd - where - f old = old <> " - " <> L.display pf - pf = snd box defaultOptions :: Sh.Runtime diff --git a/lib/Penny/Cabin/Posts/Meta.hs b/lib/Penny/Cabin/Posts/Meta.hs --- a/lib/Penny/Cabin/Posts/Meta.hs +++ b/lib/Penny/Cabin/Posts/Meta.hs @@ -58,7 +58,7 @@ toBoxList szb pdct pff = addMetadata . Ly.processPostFilters pff - . filter (maybe False id . Pe.eval pdct . snd) + . filter (Pe.rBool . flip Pe.evaluate pdct . snd) . addBalances szb addBalances diff --git a/lib/Penny/Liberty.hs b/lib/Penny/Liberty.hs --- a/lib/Penny/Liberty.hs +++ b/lib/Penny/Liberty.hs @@ -59,7 +59,6 @@ import qualified Data.Text as X import qualified Data.Text.IO as TIO import qualified Data.Time as Time -import Data.Tuple (swap) import qualified System.Console.MultiArg as MA import qualified System.Console.MultiArg.Combinator as C import System.Console.MultiArg.Combinator (OptSpec) @@ -156,7 +155,8 @@ . addFilteredNum mainFilter :: P.LPdct -> [L.Posting] -> ([C.Chunk], [L.Posting]) -mainFilter pdct = swap . E.filter indentAmt True 0 L.display pdct +mainFilter pdct = E.verboseFilter L.display indentAmt False pdct + addFilteredNum :: [a] -> [(FilteredNum, a)] addFilteredNum = L.serialItems (\s p -> (FilteredNum s, p)) diff --git a/lib/Penny/Lincoln.hs b/lib/Penny/Lincoln.hs --- a/lib/Penny/Lincoln.hs +++ b/lib/Penny/Lincoln.hs @@ -68,5 +68,5 @@ Debit -> "Dr" Credit -> "Cr" cmdty = X.unpack . unCommodity . Q.commodity $ p - qt = show . Q.qty $ p + qt = prettyShowQty . Q.qty $ p labelNo s = "(no " ++ s ++ ")" diff --git a/lib/Penny/Lincoln/Predicates.hs b/lib/Penny/Lincoln/Predicates.hs --- a/lib/Penny/Lincoln/Predicates.hs +++ b/lib/Penny/Lincoln/Predicates.hs @@ -39,6 +39,7 @@ import Data.List (intersperse) +import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as X @@ -231,14 +232,12 @@ -- ^ The right hand side -> Ordering - -- ^ The Pdct returned will be Just True if the item has a serial - -- and @compare ser rhs@ returns this Ordering; Just False if the - -- item has a srerial and @compare@ does not return this Ordering; - -- Nothing if the item does not have a serial. + -- ^ The Pdct returned will be True if the item has a serial + -- and @compare ser rhs@ returns this Ordering; False otherwise. -> P.Pdct a -serialPdct name getSer i o = P.Pdct n (P.Operand f) +serialPdct name getSer i o = P.operand n f where n = "serial " <> name <> " is " <> descCmp <> " " <> X.pack (show i) @@ -246,7 +245,8 @@ EQ -> "equal to" LT -> "less than" GT -> "greater than" - f = fmap (\ser -> compare ser i == o) . getSer + f = fromMaybe False . fmap (\ser -> compare ser i == o) + . getSer type MakeSerialPdct = Int -> Ordering -> P.Pdct Posting diff --git a/lib/Penny/Lincoln/Predicates/Siblings.hs b/lib/Penny/Lincoln/Predicates/Siblings.hs --- a/lib/Penny/Lincoln/Predicates/Siblings.hs +++ b/lib/Penny/Lincoln/Predicates/Siblings.hs @@ -248,7 +248,7 @@ -> P.Pdct E.Posting -serialPdct name getSer i o = P.Pdct n (P.Operand f) +serialPdct name getSer i o = P.operand n f where n = "serial " <> name <> " is " <> descCmp <> " " <> X.pack (show i) @@ -256,8 +256,7 @@ EQ -> "equal to" LT -> "less than" GT -> "greater than" - f = Just - . any (\ser -> compare ser i == o ) + f = any (\ser -> compare ser i == o ) . catMaybes . map getSer . E.unrollSnd diff --git a/lib/Penny/Wheat.hs b/lib/Penny/Wheat.hs --- a/lib/Penny/Wheat.hs +++ b/lib/Penny/Wheat.hs @@ -24,7 +24,6 @@ , main ) where -import Control.Monad (when) import qualified Control.Monad.Exception.Synchronous as Ex import Data.Either (partitionEithers) import Data.Maybe (mapMaybe) @@ -42,7 +41,7 @@ import qualified Penny.Steel.Sums as Su import qualified Data.Version as V -import qualified Data.Prednote.TestTree as TT +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 @@ -78,7 +77,7 @@ -- of lines, wich each line not terminated by a newline -- character. It is displayed at the end of the online help. - , tests :: [Time.UTCTime -> TT.TestTree L.Posting] + , tests :: [Time.UTCTime -> TT.Test L.Posting] -- ^ The actual tests to run. The UTCTime is the @base time@. Each -- test may decide what to do with the base time--for example, the -- test might say that all postings have to have a date on or @@ -87,30 +86,14 @@ , indentAmt :: Pe.IndentAmt -- ^ How many spaces to indent each level in a tree of tests. - , passVerbosity :: TT.Verbosity - -- ^ Verbosity for tests that pass - - , failVerbosity :: TT.Verbosity - -- ^ Verbosity for tests that fail - - , groupPred :: TT.Name -> Bool - -- ^ Group names are filtered with this function; a group is only - -- run if this function returns True. + , verbosity :: Maybe TT.TestVerbosity + -- ^ If Just, use this verbosity. If Nothing, use the default + -- verbosity provided by the tests themselves. , testPred :: TT.Name -> Bool -- ^ Test names are filtered with this function; a test is only -- run if this function returns True. - , showSkippedTests :: Bool - -- ^ Some tests might be skipped; see 'testPred'. This controls - -- whether you want to see a notification of tests that were - -- skipped. (Does not affect skipped groups; see 'groupVerbosity' - -- for that.) - - , groupVerbosity :: TT.GroupVerbosity - -- ^ Show group names? Even if you do not show the names of - -- groups, tests within the group will still be indented. - , stopOnFail :: Bool -- ^ If True, then tests will stop running immediately after a -- single test fails. If False, all tests are always run. @@ -122,25 +105,8 @@ -- ^ Tests may use this date and time as they wish; see -- 'tests'. Typically you will set this to the current instant. - , ledgers :: [String] - -- ^ Ledger files to read in from disk. } -data Parsed = Parsed - { p_indentAmt :: Pe.IndentAmt - , p_passVerbosity :: TT.Verbosity - , p_failVerbosity :: TT.Verbosity - , p_groupPred :: TT.Name -> Bool - , p_testPred :: TT.Name -> Bool - , p_showSkippedTests :: Bool - , p_groupVerbosity :: TT.GroupVerbosity - , p_stopOnFail :: Bool - , p_colorToFile :: Bool - , p_baseTime :: Time.UTCTime - , p_help :: Bool - , p_ledgers :: [String] - } - parseBaseTime :: String -> Ex.Exceptional MA.InputError Time.UTCTime parseBaseTime s = case Parsec.parse CP.dateTime "" (X.pack s) of Left e -> Ex.throw (MA.ErrorMsg $ "could not parse date: " ++ show e) @@ -152,66 +118,44 @@ "could not parse regular expression: " ++ X.unpack e Ex.Success m -> return . M.match $ m -parseArg :: String -> Parsed -> Parsed -parseArg s p = p { p_ledgers = p_ledgers p ++ [s] } - -allOpts :: [MA.OptSpec (Parsed -> Parsed)] +allOpts :: [MA.OptSpec (WheatConf -> WheatConf)] allOpts = - let allChoices = - [ ("silent", \p -> p { p_failVerbosity = TT.Silent }) - , ("minimal", \p -> p { p_failVerbosity = TT.PassFail }) - , ("false", \p -> p { p_failVerbosity = TT.FalseSubjects }) - , ("true", \p -> p { p_failVerbosity = TT.TrueSubjects }) - , ("all", \p -> p { p_failVerbosity = TT.Discards }) - ] in [ MA.OptSpec ["indentation"] "i" - (fmap (\i p -> p { p_indentAmt = i }) (MA.OneArgE MA.reader)) - - , MA.OptSpec ["pass-verbosity"] "p" $ MA.ChoiceArg allChoices - - , MA.OptSpec ["fail-verbosity"] "f" $ MA.ChoiceArg allChoices - - , MA.OptSpec ["group-regexp"] "g" - (fmap (\f p -> p { p_groupPred = f }) (MA.OneArgE parseRegexp)) + (fmap (\i p -> p { indentAmt = i }) (MA.OneArgE MA.reader)) , MA.OptSpec ["test-regexp"] "t" - (fmap (\f p -> p { p_testPred = f }) (MA.OneArgE parseRegexp)) - - , MA.OptSpec ["show-skipped-tests"] "" - ( MA.NoArg (\p -> p { p_showSkippedTests - = not (p_showSkippedTests p) })) - - , MA.OptSpec ["group-verbosity"] "G" $ MA.ChoiceArg - [ ("silent", \p -> p { p_groupVerbosity = TT.NoGroups }) - , ("active", \p -> p { p_groupVerbosity = TT.ActiveGroups }) - , ("all", \p -> p { p_groupVerbosity = TT.AllGroups }) - ] + (fmap (\f p -> p { testPred = f }) (MA.OneArgE parseRegexp)) , MA.OptSpec ["stop-on-failure"] "" - ( MA.NoArg (\p -> p { p_stopOnFail - = not (p_stopOnFail p) })) + ( MA.NoArg (\p -> p { stopOnFail + = not (stopOnFail p) })) , MA.OptSpec ["color-to-file"] "" - ( MA.NoArg (\p -> p { p_colorToFile - = not (p_colorToFile p) })) + ( MA.NoArg (\p -> p { colorToFile + = not (colorToFile p) })) , MA.OptSpec ["base-date"] "" - (fmap (\d p -> p { p_baseTime = d }) (MA.OneArgE parseBaseTime)) + (fmap (\d p -> p { baseTime = d }) (MA.OneArgE parseBaseTime)) ] -getTTOpts :: [a] -> Parsed -> TT.TestOpts a -getTTOpts as o = TT.TestOpts - { TT.tIndentAmt = p_indentAmt o - , TT.tPassVerbosity = p_passVerbosity o - , TT.tFailVerbosity = p_failVerbosity o - , TT.tGroupPred = p_groupPred o - , TT.tTestPred = p_testPred o - , TT.tShowSkippedTests = p_showSkippedTests o - , TT.tGroupVerbosity = p_groupVerbosity o - , TT.tSubjects = as - , TT.tStopOnFail = p_stopOnFail o - } +-- | Applied to the default WheatConf, returns a new WheatConf based +-- on what was parsed from the command line, and a list of strings +-- corresponding to the ledger files provided on the command line. +parseArgs :: V.Version -> WheatConf -> IO (WheatConf, [String]) +parseArgs ver c = do + parsed <- MA.simpleWithHelp (help c) MA.Intersperse + (fmap Left (Ly.version ver) : (map (fmap (Right . Left)) allOpts)) + (return . Right . Right) + let (showVers, optsAndArgs) = partitionEithers parsed + case showVers of + [] -> return () + x:_ -> x + let (opts, args) = partitionEithers optsAndArgs + fn = foldl (flip (.)) id opts + c' = fn c + return (c', args) + -- | Runs Wheat tests. Prints the result to standard output. Exits -- unsuccessfully if the user gave bad command line options or if at -- least a single test failed; exits successfully if all tests @@ -223,39 +167,34 @@ -> (S.Runtime -> WheatConf) -> IO () main ver getWc = do rt <- S.runtime - let wc = getWc rt - parsed <- MA.simpleWithHelp (help wc) MA.Intersperse - (fmap Left (Ly.version ver) : (map (fmap Right) allOpts)) - (return . (fmap Right parseArg)) - let (showVers, fns) = partitionEithers parsed - case showVers of - [] -> return () - x:_ -> x - let fn = foldl (flip (.)) id fns - psd = fn (getParsedFromWheatConf wc) - term <- Rb.smartTermFromEnv (p_colorToFile psd) IO.stdout - pfs <- getItems (p_ledgers psd) - let ttOpts = getTTOpts pfs psd - tts = zipWith ($) (tests wc) (repeat (p_baseTime psd)) - (cks, _, nFail) = TT.runTests ttOpts 0 tts - Rb.putChunks term cks - when (nFail > 0) Exit.exitFailure + (conf, args) <- parseArgs ver (getWc rt) + term <- Rb.smartTermFromEnv (colorToFile conf) IO.stdout + pstgs <- getItems args + let tsts = filter ((testPred conf) . TT.testName) + . map ($ (L.toUTC . S.currentTime $ rt)) + . tests + $ conf + bs <- mapM (runTest conf pstgs term) tsts + if and bs + then Exit.exitSuccess + else Exit.exitFailure -getParsedFromWheatConf :: WheatConf -> Parsed -getParsedFromWheatConf w = Parsed - { p_indentAmt = indentAmt w - , p_passVerbosity = passVerbosity w - , p_failVerbosity = failVerbosity w - , p_groupPred = groupPred w - , p_testPred = testPred w - , p_showSkippedTests = showSkippedTests w - , p_groupVerbosity = groupVerbosity w - , p_stopOnFail = stopOnFail w - , p_colorToFile = colorToFile w - , p_baseTime = baseTime w - , p_help = False - , p_ledgers = ledgers w - } +-- | Shows the result of a test. Exits with a failure if stopOnFail is +-- set and if the test failed. Otherwise, returns whether the test +-- succeeded or failed. +runTest + :: WheatConf + -> [L.Posting] + -> Rb.Term + -> TT.Test L.Posting + -> IO Bool +runTest c ps term test = do + let rslt = TT.evalTest test ps + cks = TT.showResult (indentAmt c) L.display (verbosity c) rslt + Rb.putChunks term cks + if stopOnFail c && not (TT.resultPass rslt) + then Exit.exitFailure + else return (TT.resultPass rslt) getItems :: [String] -> IO [L.Posting] getItems ss = fmap f $ Cop.open ss @@ -272,8 +211,8 @@ eachPostingMustBeTrue :: TT.Name -> Pe.Pdct L.Posting - -> TT.TestTree L.Posting -eachPostingMustBeTrue n = TT.eachSubjectMustBeTrue n L.display + -> TT.Test L.Posting +eachPostingMustBeTrue n pd = TT.eachSubjectMustBeTrue pd n -- | Passes if at least a particular number of postings is True. atLeastNPostings @@ -281,8 +220,8 @@ -- ^ The number of postings that must be true for the test to pass -> TT.Name -> Pe.Pdct L.Posting - -> TT.TestTree L.Posting -atLeastNPostings i n = TT.nSubjectsMustBeTrue n L.display i + -> TT.Test L.Posting +atLeastNPostings i n pd = TT.nSubjectsMustBeTrue pd n i -- -- Help @@ -302,37 +241,10 @@ , " -i, --indentation AMT" , " Indent each level by this many spaces" , " " ++ dflt (show . indentAmt $ wc) - , " -p, --pass-verbosity VERBOSITY" - , " Verbosity for tests that pass. Argument may be:" - , " silent - show nothing at all" - , " minimal - show whether the test passed or failed" - , " false - show subjects that are false" - , " true - show subjects that are true or false" - , " all - show all subjects" - , " " ++ dflt (showVerbosity . passVerbosity $ wc) - , " -f, --fail-verbosity VERBOSITY" - , " Verbosity for tests that fail." - , " (uses same VERBOSITY options as --pass-verbosity)" - , " " ++ dflt (showVerbosity . failVerbosity $ wc) - , " -g, --group-regexp REGEXP" - , " Run only groups whose name matches the given" - , " Perl-compatible regular expression" - , " (overrides the compiled-in default)" , " -t, --test-regexp REGEXP" , " Run only tests whose name matches the given" , " Perl-compatible regular expression" , " (overrides the compiled-in default)" - , " --show-skipped-tests" - , " Toggle whether to show tests that are skipped" - , " using the --test-regexp option" - , " (does not affect groups that are skipped; see next option)" - , " " ++ dflt (show . showSkippedTests $ wc) - , " --G, group-verbosity ARG" - , " Control which group names are shown. Argument may be:" - , " silent - do not show any group names" - , " active - show group names that were not skipped" - , " all - show all group names, including skipped ones" - , " " ++ dflt (showGroupVerbosity . groupVerbosity $ wc) , " --stop-on-failure" , " Stop running tests after a single test fails" , " " ++ dflt (show . stopOnFail $ wc) @@ -349,19 +261,4 @@ dflt :: String -> String dflt s = "(default: " ++ s ++ ")" - -showVerbosity :: TT.Verbosity -> String -showVerbosity v = case v of - TT.Silent -> "silent" - TT.PassFail -> "minimal" - TT.FalseSubjects -> "false" - TT.TrueSubjects -> "true" - TT.Discards -> "all" - -showGroupVerbosity :: TT.GroupVerbosity -> String -showGroupVerbosity v = case v of - TT.NoGroups -> "silent" - TT.ActiveGroups -> "active" - TT.AllGroups -> "all" - diff --git a/penny-lib.cabal b/penny-lib.cabal --- a/penny-lib.cabal +++ b/penny-lib.cabal @@ -1,5 +1,5 @@ Name: penny-lib -Version: 0.16.0.0 +Version: 0.18.0.0 Cabal-version: >=1.8 Build-Type: Simple License: BSD3 @@ -50,7 +50,7 @@ , ofx ==0.2.* , old-locale ==1.0.* , parsec >= 3.1.2 && < 3.2 - , prednote == 0.10.* + , prednote == 0.12.* , pretty-show ==1.5.* , rainbow ==0.4.* , semigroups ==0.9.* @@ -169,7 +169,7 @@ , old-locale ==1.0.* , parsec >= 3.1.2 && < 3.2 , pcre-light ==0.4.* - , prednote == 0.10.* + , prednote == 0.12.* , pretty-show ==1.5.* , rainbow ==0.4.* , semigroups ==0.9.* @@ -210,7 +210,7 @@ , old-locale ==1.0.* , parsec >= 3.1.2 && < 3.2 , pcre-light ==0.4.* - , prednote == 0.10.* + , prednote == 0.12.* , pretty-show ==1.5.* , rainbow ==0.4.* , semigroups ==0.9.*