packages feed

penny-lib 0.16.0.0 → 0.18.0.0

raw patch · 8 files changed

+81/−197 lines, 8 filesdep ~prednote

Dependency ranges changed: prednote

Files

lib/Penny/Cabin/Posts.hs view
@@ -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
lib/Penny/Cabin/Posts/Meta.hs view
@@ -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
lib/Penny/Liberty.hs view
@@ -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))
lib/Penny/Lincoln.hs view
@@ -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 ++ ")"
lib/Penny/Lincoln/Predicates.hs view
@@ -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
lib/Penny/Lincoln/Predicates/Siblings.hs view
@@ -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
lib/Penny/Wheat.hs view
@@ -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"-
penny-lib.cabal view
@@ -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.*