penny 0.24.0.0 → 0.26.0.0

raw patch · 17 files changed

+587/−423 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• bin/penny-selloff.hs +2/−2
• doc/man/penny.1 +11/−0
• lib/Penny/Cabin/Balance/Convert.hs +115/−41
• lib/Penny/Cabin/Balance/Convert/Chunker.hs +4/−1
• lib/Penny/Cabin/Balance/Convert/ChunkerPct.hs +254/−0
• lib/Penny/Cabin/Balance/Convert/Options.hs +1/−0
• lib/Penny/Cabin/Balance/Convert/Parser.hs +41/−17
• lib/Penny/Cabin/Balance/MultiCommodity.hs +12/−12
• lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs +4/−1
• lib/Penny/Cabin/Balance/Util.hs +95/−66
• lib/Penny/Cabin/Posts/Growers.hs +5/−1
• lib/Penny/Cabin/Scheme.hs +5/−5
• lib/Penny/Lincoln.hs +2/−0
• lib/Penny/Lincoln/Bits/Qty.hs +11/−0
• lib/Penny/Lincoln/Natural.hs +22/−0
• lib/Penny/Steel/NestedMap.hs +0/−275
• penny.cabal +3/−2

@@ -170,8 +170,8 @@   ]  calcBalances :: [Cop.LedgerItem] -> [(L.Account, L.Balance)]-calcBalances =-  BU.flatten+calcBalances+  = BU.flatten   . BU.balances (ShowZeroBalances False)   . map (\p -> ((), p))   . concatMap L.transactionToPostings

@@ -726,6 +726,17 @@ Sort in ascending (default) or descending order  .TP+.BI "--percent | -%"+Show each account total as a percentage of the parent account total.++.TP+.BI "--round | -r " PLACES+Like+.I --percent+but round to the specified number of decimal places rather than the+default of zero places.++.TP .B --help | -h Show help and exit 

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- | The Convert report. This report converts all account balances to -- a single commodity, which must be specified. @@ -18,6 +19,7 @@ import qualified Penny.Cabin.Scheme as Scheme import qualified Penny.Cabin.Balance.Util as U import qualified Penny.Cabin.Balance.Convert.Chunker as K+import qualified Penny.Cabin.Balance.Convert.ChunkerPct as KP import qualified Penny.Cabin.Balance.Convert.Options as O import qualified Penny.Cabin.Balance.Convert.Parser as P import qualified Penny.Cabin.Interface as I@@ -28,7 +30,8 @@ import qualified Data.Either as Ei import qualified Data.Map as M import qualified Data.Text as X-import Data.Monoid (mempty, mappend, mconcat)+import Data.Maybe (catMaybes)+import Data.Monoid (mconcat, (<>)) import qualified System.Console.MultiArg as MA import qualified System.Console.Rainbow as Rb @@ -36,7 +39,11 @@ -- need to use if you are supplying options programatically (as -- opposed to parsing them in from the command line.) data Opts = Opts-  { balanceFormat :: L.Amount L.Qty -> X.Text+  { format :: Either (L.Amount L.Qty -> X.Text) P.RoundTo+  -- ^ If you want a convert report that shows a single commodity,+  -- pass a Left showing how to display each amount.  If you want a+  -- convert report that shows percentages, pass a Right here with how+  -- many places to round to.   , showZeroBalances :: CO.ShowZeroBalances   , sorter :: Sorter   , target :: L.To@@ -122,6 +129,60 @@   , _tbTo :: L.To   } +forestToPercents+  :: E.Forest (L.SubAccount, L.BottomLine)+  -> E.Forest (L.SubAccount, Maybe KP.Percent)+forestToPercents ls =+  let tot = sumBottomLines . map (snd . E.rootLabel) $ ls+  in map (treeToPercent tot) ls++treeToPercent+  :: Maybe L.Qty+  -- ^ Sum of all BottomLines at this level+  -> E.Tree (L.SubAccount, L.BottomLine)+  -> E.Tree (L.SubAccount, Maybe KP.Percent)+treeToPercent qty (E.Node (acct, bl) cs) = E.Node (acct, mayPct) cs'+  where+    mayPct = maybe Nothing (flip bottomLineToPercent bl) qty+    cs' = forestToPercents cs++bottomLineToQty :: L.BottomLine -> Maybe (L.DrCr, L.Qty)+bottomLineToQty b = case b of+  L.Zero -> Nothing+  L.NonZero (L.Column dc q) -> Just (dc, q)++sumBottomLines :: [L.BottomLine] -> Maybe L.Qty+sumBottomLines ls = case catMaybes . map bottomLineToQty $ ls of+  [] -> Nothing+  x:xs -> Just $ foldl (\a b -> L.add a (snd b)) (snd x) xs++bottomLineToPercent+  :: L.Qty+  -- ^ Sum of all All BottomLines in this level+  -> L.BottomLine+  -- ^ This BottomLine+  -> Maybe KP.Percent+bottomLineToPercent tot bl = fmap f . bottomLineToQty $ bl+  where+    f (dc, q) = KP.Percent dc (L.divide q tot)+++-- | Converts rows for a percentage report.+rowsPct+  :: L.To+  -- ^ To commodity+  -> E.Forest (L.SubAccount, Maybe KP.Percent)+  -> [KP.Row]+rowsPct to frt = first:rest+  where+    first = KP.ROneCol $ KP.OneColRow 0 desc+    desc = "All amounts reported in percents in commodity: "+           <> (L.unCommodity . L.unTo $ to)+    rest = map mainRowPct+         . concatMap E.flatten+         . map U.labelLevels+         $ frt+ -- | Converts the balance data in preparation for screen rendering. rows :: ForestAndBL -> ([K.Row], L.To) rows (ForestAndBL f tot to) = (first:second:rest, to)@@ -138,6 +199,9 @@            $ f  +mainRowPct :: (Int, (L.SubAccount, Maybe KP.Percent)) -> KP.Row+mainRowPct (l, (a, p)) = KP.RMain $ KP.MainRow l (L.text a) p+ mainRow :: (Int, (L.SubAccount, L.BottomLine)) -> K.Row mainRow (l, (a, b)) = K.RMain $ K.MainRow l x b   where@@ -151,13 +215,20 @@   -> [L.PricePoint]   -> [(a, L.Posting)]   -> Ex.Exceptional X.Text [Rb.Chunk]-report os@(Opts getFmt _ _ _ _ txtFormats) ps bs = do+report os@(Opts eiFmt _ _ tgt _ txtFormats) ps bs = do   fstBl <- sumConvertSort os ps bs-  let (rs, L.To cy) = rows fstBl-      fmt q = getFmt (L.Amount q cy)-  return $ K.rowsToChunks txtFormats fmt rs+  return $ case eiFmt of+    Left getFmt ->+      let (rs, L.To cy) = rows fstBl+          fmt q = getFmt (L.Amount q cy)+      in K.rowsToChunks txtFormats fmt rs+    Right rnd ->+      let frt = forestToPercents (_tbForest fstBl)+          rws = rowsPct tgt frt+      in KP.rowsToChunks txtFormats rnd rws  + -- | Creates a report respecting the standard interface for reports -- whose options are parsed in from the command line. cmdLineReport@@ -168,7 +239,7 @@     mkMode _ _ chgrs _ fsf = MA.modeHelp       "convert"       (const (help o))-      (process rt chgrs o fsf)+      (return . process rt chgrs o fsf)       (map (fmap Right) P.allOptSpecs)       MA.Intersperse       (return . Left)@@ -179,22 +250,18 @@   -> Scheme.Changers   -> O.DefaultOpts   -> ([L.Transaction] -> [(Ly.LibertyMeta, L.Posting)])-  -> [Either String (P.Opts -> Ex.Exceptional String P.Opts)]-  -> Ex.Exceptional X.Text I.ArgsAndReport-process rt chgrs defaultOpts fsf ls = do+  -> [Either String (P.Opts -> P.Opts)]+  -> I.ArgsAndReport+process rt chgrs defaultOpts fsf ls =   let (posArgs, parsed) = Ei.partitionEithers ls-      op' = foldl (>>=) (return (O.toParserOpts defaultOpts rt)) parsed-  case op' of-      Ex.Exception s -> Ex.throw . X.pack $ s-      Ex.Success g -> return $-        let noDefault = X.pack "no default price found"-            f = fromParsedOpts chgrs g-            pr fmt ts pps = do-              rptOpts <- Ex.fromMaybe noDefault $-                f pps fmt-              let boxes = fsf ts-              report rptOpts pps boxes-        in (posArgs, pr)+      op' = foldl (flip (.)) id parsed (O.toParserOpts defaultOpts rt)+      noDefault = X.pack "no default price found"+      f = fromParsedOpts chgrs op'+      pr fmt ts pps = do+        rptOpts <- Ex.fromMaybe noDefault $ f pps fmt+        let boxes = fsf ts+        report rptOpts pps boxes+  in (posArgs, pr)   -- | Sums the balances from the bottom to the top of the tree (so that@@ -209,13 +276,13 @@ sumConvertSort os ps bs = mkResult <$> convertedFrst <*> convertedTot   where     (Opts _ szb str tgt dt _) = os-    bals = U.balances szb bs-    (frst, tot) = U.sumForest mempty mappend bals+    (topTot, unsorted) = U.balances szb bs+    (sorted, frstTot) = U.sumForest unsorted     convertBal (a, bal) =         (\bl -> (a, bl)) <$> convertBalance db dt tgt bal     db = buildDb ps-    convertedFrst = mapM (Tvbl.mapM convertBal) frst-    convertedTot = convertBalance db dt tgt tot+    convertedFrst = mapM (Tvbl.mapM convertBal) sorted+    convertedTot = convertBalance db dt tgt (frstTot <> topTot)     mkResult f t = ForestAndBL (U.sortForest str f) t tgt  -- | Determine the most frequent To commodity.@@ -235,15 +302,16 @@   :: Scheme.Changers   -> P.Opts   -> DoReport-fromParsedOpts chgrs (P.Opts szb tgt dt so sb) =-  \pps fmt -> case tgt of-    P.ManualTarget to ->-      Just $ Opts fmt szb (getSorter so sb) to dt chgrs-    P.AutoTarget ->-      case mostFrequent pps of-        Nothing -> Nothing-        Just to ->-          Just $ Opts fmt szb (getSorter so sb) to dt chgrs+fromParsedOpts chgrs (P.Opts szb tgt dt so sb mayRnd) pps fmtAmt =+  let fmt = maybe (Left fmtAmt) Right mayRnd+  in case tgt of+       P.ManualTarget to ->+         Just $ Opts fmt szb (getSorter so sb) to dt chgrs+       P.AutoTarget ->+         case mostFrequent pps of+           Nothing -> Nothing+           Just to ->+             Just $ Opts fmt szb (getSorter so sb) to dt chgrs  -- | Returns a function usable to sort pairs of SubAccount and -- BottomLine depending on how you want them sorted.@@ -278,6 +346,7 @@         qt = compare (Bal.colQty c1) (Bal.colQty c2)         na = compare n1 n2 + ------------------------------------------------------------ -- ## Help ------------------------------------------------------------@@ -322,12 +391,17 @@     ++ ifDefault (O.sortBy o == P.SortByName)     ++ " or by quantity"     ++ ifDefault (O.sortBy o == P.SortByQty)-  , "--ascending"-  , "  Sort in ascending order"-    ++ ifDefault (O.sortOrder o == CP.Ascending)-  , "--descending"-  , "  Sort in descending order"-    ++ ifDefault (O.sortOrder o == CP.Descending)+  , "--order ascending|descending"+  , "  Sort order (default: "+       ++ if O.sortOrder o == CP.Ascending+          then "ascending" else "descending"+       ++ ")"+  , ""+  , "--percent, -%"+  , "  Show each account total as a percentage of the parent account"+  , "--round PLACES, -r PLACES"+  , "  Like --percent, but round to this many decimal places"+  , "  rather than the default 0 places"   , ""   , "--help, -h"   , "  Show this help and exit"

@@ -227,7 +227,10 @@ balanceChunks chgrs fmt vn bl = (chkDc, chkQt)   where     eo = E.fromVisibleNum vn-    chkDc = E.bottomLineToDrCr bl eo chgrs+    chkDc = E.bottomLineToDrCr mayDc eo chgrs+    mayDc = case bl of+      L.Zero -> Nothing+      L.NonZero c -> Just $ L.colDrCr c     qtFmt = E.getEvenOddLabelValue lbl eo chgrs     chkQt = qtFmt $ Rb.Chunk mempty t     (lbl, t) = case bl of

@@ -0,0 +1,254 @@+{-# LANGUAGE OverloadedStrings #-}+module Penny.Cabin.Balance.Convert.ChunkerPct+  ( MainRow(..)+  , OneColRow(..)+  , Row(..)+  , Percent(..)+  , rowsToChunks+  ) where+++import Control.Applicative+  (Applicative (pure), (<$>), (<*>))+import Data.Monoid (mempty)+import qualified Penny.Cabin.Scheme as E+import qualified Penny.Cabin.Meta as Meta+import qualified Penny.Cabin.Row as R+import qualified Penny.Lincoln as L+import qualified Data.Foldable as Fdbl+import qualified Data.Text as X+import qualified System.Console.Rainbow as Rb+import Penny.Cabin.Balance.Convert.Parser (RoundTo, unRoundTo)+import Text.Printf (printf)++type IsEven = Bool++data Columns a = Columns {+  acct :: a+  , drCr :: a+  , quantity :: a+  } deriving Show++instance Functor Columns where+  fmap f c = Columns {+    acct = f (acct c)+    , drCr = f (drCr c)+    , quantity = f (quantity c)+    }++instance Applicative Columns where+  pure a = Columns a a a+  fn <*> fa = Columns {+    acct = (acct fn) (acct fa)+    , drCr = (drCr fn) (drCr fa)+    , quantity = (quantity fn) (quantity fa)+     }++data PreSpec = PreSpec {+  _justification :: R.Justification+  , _padSpec :: (E.Label, E.EvenOdd)+  , bits :: Rb.Chunk }++-- | When given a list of columns, determine the widest row in each+-- column.+maxWidths :: [Columns PreSpec] -> Columns R.Width+maxWidths = Fdbl.foldl' maxWidthPerColumn (pure (R.Width 0))++-- | Applied to a Columns of PreSpec and a Colums of widths, return a+-- Columns that has the wider of the two values.+maxWidthPerColumn ::+  Columns R.Width+  -> Columns PreSpec+  -> Columns R.Width+maxWidthPerColumn w p = f <$> w <*> p where+  f old new = max old (R.Width . X.length . Rb._text . bits $ new)++-- | Changes a single set of Columns to a set of ColumnSpec of the+-- given width.+preSpecToSpec ::+  Columns R.Width+  -> Columns PreSpec+  -> Columns R.ColumnSpec+preSpecToSpec ws p = f <$> ws <*> p where+  f width (PreSpec j ps bs) = R.ColumnSpec j width ps [bs]++resizeColumnsInList :: [Columns PreSpec] -> [Columns R.ColumnSpec]+resizeColumnsInList cs = map (preSpecToSpec w) cs where+  w = maxWidths cs+++widthSpacerAcct :: Int+widthSpacerAcct = 4++widthSpacerDrCr :: Int+widthSpacerDrCr = 1++colsToBits+  :: E.Changers+  -> IsEven+  -> Columns R.ColumnSpec+  -> [Rb.Chunk]+colsToBits chgrs isEven (Columns a dc q) = let+  fillSpec = if isEven+             then (E.Other, E.Even)+             else (E.Other, E.Odd)+  spacer w = R.ColumnSpec j (R.Width w) fillSpec []+  j = R.LeftJustify+  cs = a+       : spacer widthSpacerAcct+       : dc+       : spacer widthSpacerDrCr+       : q+       : []+  in R.row chgrs cs++colsListToBits+  :: E.Changers+  -> [Columns R.ColumnSpec]+  -> [[Rb.Chunk]]+colsListToBits chgrs = zipWith f bools where+  f b c = colsToBits chgrs b c+  bools = iterate not True++preSpecsToBits+  :: E.Changers+  -> [Columns PreSpec]+  -> [Rb.Chunk]+preSpecsToBits chgrs =+  concat+  . colsListToBits chgrs+  . resizeColumnsInList++data Row = RMain MainRow | ROneCol OneColRow++-- | Displays a one-column row.+data OneColRow = OneColRow {+  ocIndentation :: Int+  -- ^ Indent the text by this many levels (not by this many+  -- spaces; this number is multiplied by another number in the+  -- Chunker source to arrive at the final indentation amount)++  , ocText :: X.Text+  -- ^ Text for the left column+  }++data Percent = Percent+  { pctDrCr :: L.DrCr+  , pctAmount :: Double+  } deriving (Eq, Show)+++-- | Displays a Double, rounded to the specified number of decimal+-- places.+dispRounded :: RoundTo -> Double -> X.Text+dispRounded rnd+  = X.pack+  . printf ("%." ++ show (L.unNonNegative . unRoundTo $ rnd) ++ "f")++-- | Displays a single account in a Balance report. In a+-- single-commodity report, this account will only be one screen line+-- long. In a multi-commodity report, it might be multiple lines long,+-- with one screen line for each commodity.+data MainRow = MainRow {+  mrIndentation :: Int+  -- ^ Indent the account name by this many levels (not by this many+  -- spaces; this number is multiplied by another number in the+  -- Chunker source to arrive at the final indentation amount)++  , mrText :: X.Text+  -- ^ Text for the name of the account++  , mrPercent :: Maybe Percent+  -- ^ If Nothing, display dashes for the percent.+  }+++rowsToChunks+  :: E.Changers+  -> RoundTo+  -- ^ Round by this many places+  -> [Row]+  -> [Rb.Chunk]+rowsToChunks chgrs rnd =+  preSpecsToBits chgrs+  . rowsToColumns chgrs rnd++rowsToColumns+  :: E.Changers+  -> RoundTo+  -- ^ Round by this many places++  -> [Row]+  -> [Columns PreSpec]+rowsToColumns chgrs rnd+  = map (mkRow chgrs rnd)+  . L.serialItems (\ser r -> (Meta.VisibleNum ser, r))+++mkRow+  :: E.Changers+  -> RoundTo+  -> (Meta.VisibleNum, Row)+  -> Columns PreSpec+mkRow chgrs rnd (vn, r) = case r of+  RMain m -> mkMainRow chgrs rnd (vn, m)+  ROneCol c -> mkOneColRow chgrs (vn, c)++mkOneColRow+  :: E.Changers+  -> (Meta.VisibleNum, OneColRow)+  -> Columns PreSpec+mkOneColRow chgrs (vn, (OneColRow i t)) = Columns ca cd cq+  where+    txt = X.append indents t+    indents = X.replicate (indentAmount * max 0 i)+              (X.singleton ' ')+    eo = E.fromVisibleNum vn+    lbl = E.Other+    ca = PreSpec R.LeftJustify (lbl, eo)+         (E.getEvenOddLabelValue lbl eo chgrs . Rb.Chunk mempty $ txt)+    cd = PreSpec R.LeftJustify (lbl, eo)+         (E.getEvenOddLabelValue lbl eo chgrs mempty)+    cq = cd++mkMainRow+  :: E.Changers+  -> RoundTo+  -> (Meta.VisibleNum, MainRow)+  -> Columns PreSpec+mkMainRow chgrs rnd (vn, (MainRow i acctTxt b)) = Columns ca cd cq+  where+    applyFmt = E.getEvenOddLabelValue lbl eo chgrs+    eo = E.fromVisibleNum vn+    lbl = E.Other+    ca = PreSpec R.LeftJustify (lbl, eo) (applyFmt (Rb.Chunk mempty txt))+      where+        txt = X.append indents acctTxt+        indents = X.replicate (indentAmount * max 0 i)+                  (X.singleton ' ')+    cd = PreSpec R.LeftJustify (lbl, eo) (applyFmt cksDrCr)+    cq = PreSpec R.LeftJustify (lbl, eo) (applyFmt cksQty)+    (cksDrCr, cksQty) = balanceChunks chgrs rnd vn b+++balanceChunks+  :: E.Changers+  -> RoundTo+  -> Meta.VisibleNum+  -> Maybe Percent+  -> (Rb.Chunk, Rb.Chunk)+balanceChunks chgrs rnd vn pct = (chkDc, chkQt)+  where+    eo = E.fromVisibleNum vn+    chkDc = E.bottomLineToDrCr (fmap pctDrCr pct) eo chgrs+    qtFmt = E.getEvenOddLabelValue lbl eo chgrs+    chkQt = qtFmt $ Rb.Chunk mempty t+    (lbl, t) = case pct of+      Nothing -> (E.Zero, X.pack "--")+      Just (Percent dc qt) ->+        (E.dcToLbl dc, dispRounded rnd . (* 100) $ qt)+++indentAmount :: Int+indentAmount = 2+

@@ -26,6 +26,7 @@   , P.dateTime = S.currentTime rt   , P.sortOrder = sortOrder d   , P.sortBy = sortBy d+  , P.percentRpt = Nothing   }  defaultOptions :: DefaultOpts

@@ -3,6 +3,7 @@   Opts(..)   , Target(..)   , SortBy(..)+  , RoundTo(..)   , allOptSpecs   ) where @@ -17,6 +18,10 @@ import qualified Text.Parsec as Parsec  +-- | Round to this many decimal places in the Percent report.+newtype RoundTo = RoundTo { unRoundTo :: L.NonNegative }+  deriving (Eq, Show, Ord)+ -- | Is the target commodity determined by the user or automatically? data Target = AutoTarget | ManualTarget L.To @@ -31,22 +36,25 @@   , dateTime :: L.DateTime   , sortOrder :: P.SortOrder   , sortBy :: SortBy+  , percentRpt :: Maybe RoundTo+  -- ^ If the user wants a percentage report, set this.   }  -- | Do not be tempted to change the setup in this module so that the -- individual functions such as parseColor and parseBackground return -- parsers rather than OptSpec. Such an arrangement breaks the correct -- parsing of abbreviated long options.-allOptSpecs :: [C.OptSpec (Opts -> Ex.Exceptional String Opts)]+allOptSpecs :: [C.OptSpec (Opts -> Opts)] allOptSpecs =-  [ fmap toExc parseZeroBalances+  [ parseZeroBalances   , parseCommodity-  , fmap toExc parseAuto+  , parseAuto   , parseDate-  , fmap toExc parseSort-  , fmap toExc parseOrder ]-  where-    toExc f = return . f+  , parseSort+  , parseOrder+  , parsePct+  , parseRound+  ]  parseZeroBalances :: C.OptSpec (Opts -> Opts) parseZeroBalances = fmap f P.zeroBalances@@ -54,26 +62,26 @@     f x o = o { showZeroBalances = x }  -parseCommodity :: C.OptSpec (Opts -> Ex.Exceptional String Opts)-parseCommodity = C.OptSpec ["commodity"] "c" (C.OneArg f)+parseCommodity :: C.OptSpec (Opts -> Opts)+parseCommodity = C.OptSpec ["commodity"] "c" (C.OneArgE f)   where-    f a1 os =+    f a1 =       case Parsec.parse Pc.lvl1Cmdty "" (X.pack a1) of-        Left _ -> Ex.throw $ "invalid commodity: " ++ a1-        Right g -> return $ os { target = ManualTarget . L.To $ g }+        Left _ -> Ex.throw . C.ErrorMsg $ "invalid commodity"+        Right g -> return $ \os -> os { target = ManualTarget . L.To $ g }  parseAuto :: C.OptSpec (Opts -> Opts) parseAuto = C.OptSpec ["auto-commodity"] "" (C.NoArg f)   where     f os = os { target = AutoTarget } -parseDate :: C.OptSpec (Opts -> Ex.Exceptional String Opts)-parseDate = C.OptSpec ["date"] "d" (C.OneArg f)+parseDate :: C.OptSpec (Opts -> Opts)+parseDate = C.OptSpec ["date"] "d" (C.OneArgE f)   where-    f a1 os =+    f a1 =       case Parsec.parse Pc.dateTime "" (X.pack a1) of-        Left _ -> Ex.throw $ "invalid date: " ++ a1-        Right g -> return $ os { dateTime = g }+        Left _ -> Ex.throw . C.ErrorMsg $ "invalid date"+        Right g -> return $ \os -> os { dateTime = g }  parseSort :: C.OptSpec (Opts -> Opts) parseSort = C.OptSpec ["sort"] "s" (C.ChoiceArg ls)@@ -85,3 +93,19 @@ parseOrder = fmap f P.order   where     f x o = o { sortOrder = x }++parsePct :: C.OptSpec (Opts -> Opts)+parsePct = C.OptSpec ["percent"] "%" (C.NoArg f)+  where+    f o = o { percentRpt = Just (RoundTo . maybe e id . L.nonNegative $ 0) }+    e = error $ "Penny.Cabin.Balance.Convert.Parser.parsePct: "+                ++ "error: zero is not non-negative"++parseRound :: C.OptSpec (Opts -> Opts)+parseRound = C.OptSpec ["round"] "r" (C.OneArgE f)+  where+    f a = do+      i <- C.reader a+      case L.nonNegative i of+        Nothing -> Ex.throw . C.ErrorMsg $ "argument is negative"+        Just g -> return $ \o -> o { percentRpt = Just (RoundTo g) }

@@ -19,7 +19,7 @@ import qualified Data.Either as Ei import qualified Data.Map as M import qualified Penny.Cabin.Options as CO-import Data.Monoid (mappend, mempty)+import Data.Monoid ((<>)) import qualified Data.Text as X import qualified Data.Tree as E import qualified Penny.Cabin.Balance.MultiCommodity.Chunker as K@@ -69,11 +69,13 @@   -> (L.SubAccount -> L.SubAccount -> Ordering)   -> [(a, L.Posting)]   -> (E.Forest (L.SubAccount, L.Balance), L.Balance)-summedSortedBalTree szb o =-  U.sumForest mempty mappend-  . U.sortForest o'-  . U.balances szb+summedSortedBalTree szb o ps = (forest, bal)   where+    (topBal, unsorted) = U.balances szb ps+    (forest, forestSum) = U.sumForest+                        . U.sortForest o'+                        $ unsorted+    bal = topBal <> forestSum     o' x y = o (fst x) (fst y)  rows ::@@ -153,13 +155,11 @@     ++ ifDefault ( not . CO.unShowZeroBalances                  . P.showZeroBalances $ o)   , ""-  , "--ascending"-  , "  Sort in ascending order by account name"-    ++ ifDefault (P.order o == CP.Ascending)--  , "--descending"-  , "  Sort in descending order by account name"-    ++ ifDefault (P.order o == CP.Descending)+  , "--order ascending|descending"+  , "  Sort in this order by account name (default: "+    ++ if P.order o == CP.Ascending+       then "ascending" else "descending"+    ++ ")"    , ""   , "--help, -h"

@@ -214,7 +214,10 @@   -> (Rb.Chunk, Rb.Chunk, Rb.Chunk) balanceChunks chgrs fmt eo (cty, bl) = (chkDc, chkCt, chkQt)   where-    chkDc = E.bottomLineToDrCr bl eo chgrs+    chkDc = E.bottomLineToDrCr dc eo chgrs+    dc = case bl of+      L.Zero -> Nothing+      L.NonZero c -> Just $ L.colDrCr c     chkCt = E.bottomLineToCmdty chgrs eo (cty, bl)     chkQt = E.bottomLineToQty chgrs fmt eo (cty, bl) 

@@ -17,52 +17,29 @@   , lastMode   ) where +import Control.Arrow (second, first) import qualified Penny.Cabin.Options as CO import qualified Penny.Lincoln as L-import qualified Penny.Steel.NestedMap as NM-import qualified Data.Foldable as Fdbl+import Data.Tuple (swap)+import Data.Either (partitionEithers) import qualified Data.Map as M import Data.Ord (comparing) import Data.List (sortBy, maximumBy, groupBy)-import Data.Monoid (mconcat, Monoid)+import Data.Monoid (mconcat, Monoid, mempty, mappend) import Data.Maybe (mapMaybe) import qualified Data.Tree as T import qualified Penny.Lincoln.Queries as Q --- | Constructs a forest sorted into tiers based on lists of keys that--- are extracted from the elements.-tieredForest ::-  Ord k-  => (a -> [k])-  -- ^ Extracts a key from the elements we are putting in the tree. If-  -- this function returns an empty list for any element, the element-  -- will not appear in the tiered forest.-  -> [a]-  -> T.Forest (k, [a])-tieredForest getKeys ls = fmap (fmap revSnd) . NM.toForest $ nm-  where-    revSnd (a, xs) = (a, reverse xs)-    nm = foldr f NM.empty ls-    f a m = NM.relabel m ps-      where-        ps = case getKeys a of-          [] -> []-          ks ->-            let mkInitPair k = (k, maybe [] id)-                mkLastPair k = (k, maybe [a] (a:))-            in (map mkInitPair . init $ ks)-               ++ [(mkLastPair (last ks))]- -- | Takes a list of postings and puts them into a Forest. Each level -- of each of the trees corresponds to a sub account. The label of the -- node tells you the sub account name and gives you a list of the -- postings at that level. tieredPostings   :: [(a, L.Posting)]-  -> T.Forest (L.SubAccount, [(a, L.Posting)])-tieredPostings = tieredForest e+  -> ([(a, L.Posting)], T.Forest (L.SubAccount, [(a, L.Posting)]))+tieredPostings = second (map (fmap swap)) . tieredForest e   where-    e = Fdbl.toList . L.unAccount . Q.account . snd+    e = L.unAccount . Q.account . snd  -- | Keeps only Trees that match a given condition. First examines -- child trees to determine whether they should be retained. If a@@ -79,32 +56,37 @@ -- | Puts all Boxes into a Tree and sums the balances. Removes -- accounts that have empty balances if requested. Does NOT sum -- balances from the bottom up.-balances ::-  CO.ShowZeroBalances+balances+  :: CO.ShowZeroBalances   -> [(a, L.Posting)]-  -> T.Forest (L.SubAccount, L.Balance)-balances (CO.ShowZeroBalances szb) =-  remover-  . map (fmap (mapSnd boxesBalance))+  -> (L.Balance, T.Forest (L.SubAccount, L.Balance))+balances (CO.ShowZeroBalances szb)+  = first boxesBalance+  . second remover+  . second (map (fmap (second boxesBalance)))   . tieredPostings   where     remover =       if szb       then id       else filterForest (not . M.null . L.unBalance . snd)-           . map (fmap (mapSnd L.removeZeroCommodities))+           . map (fmap (second L.removeZeroCommodities))   -- | Takes a tree of Balances (like what is produced by the 'balances' -- function) and produces a flat list of accounts with the balance of--- each account.+-- each account. Also adds in the first balance, which is for Accounts+-- that have no sub-accounts. flatten-  :: T.Forest (L.SubAccount, L.Balance)+  :: (L.Balance, T.Forest (L.SubAccount, L.Balance))   -> [(L.Account, L.Balance)]-flatten =-  concatMap T.flatten-  . map (fmap toPair) . forestWithParents+flatten (top, frst) = (L.Account [], top) : rest   where+    rest+      = concatMap T.flatten+      . map (fmap toPair)+      . forestWithParents+      $ frst     toPair ((s, b), ls) =       case reverse . map fst $ ls of         [] -> (L.Account [s], b)@@ -132,33 +114,23 @@ -- element is the forest, but with the second element of each node -- replaced with the sum of that node and all its children. The second -- element is the sum of all the second elements in the forest.-sumForest ::-  s-  -- ^ Zero--  -> (s -> s -> s)-  -- ^ Combiner--  -> T.Forest (a, s)+sumForest+  :: Monoid s+  => T.Forest (a, s)   -> (T.Forest (a, s), s)-sumForest z f ts = (ts', s)+sumForest ts = (ts', s)   where-    ts' = map (sumTree z f) ts-    s = foldr f z . map (snd . T.rootLabel) $ ts'+    ts' = map sumTree ts+    s = foldr mappend mempty . map (snd . T.rootLabel) $ ts'  -- | Sums a tree from the bottom up.-sumTree ::-  s-  -- ^ Zero--  -> (s -> s -> s)-  -- ^ Combiner--  ->  T.Tree (a, s)+sumTree+  :: Monoid s+  => T.Tree (a, s)   -> T.Tree (a, s)-sumTree z f (T.Node (a, s) cs) = T.Node (a, f s cSum) cs'+sumTree (T.Node (a, s) cs) = T.Node (a, mappend s cSum) cs'   where-    (cs', cSum) = sumForest z f cs+    (cs', cSum) = sumForest cs   boxesBalance :: [(a, L.Posting)] -> L.Balance@@ -168,9 +140,6 @@   . map Q.entry   . map snd -mapSnd :: (a -> b) -> (f, a) -> (f, b)-mapSnd f (x, a) = (x, f a)- -- | Label each level of a Tree with an integer indicating how deep it -- is. The top node of the tree is level 0. labelLevels :: T.Tree a -> T.Tree (Int, a)@@ -231,3 +200,63 @@   let lengths = map (\ls -> (ls, length ls)) as       maxLen = maximum . map snd $ lengths   in map fst . filter (\(_, len) -> len == maxLen) $ lengths++--+-- # Tiered forest+--++-- | Places items into a tiered forest.+tieredForest+  :: Ord b+  => (a -> [b])+  -- ^ Function that, when applied to an item, returns a list.  The+  -- items will be placed into a tiered forest according to each list.++  -> [a]+  -- ^ List of items to put into the forest++  -> ([a], T.Forest ([a], b))+  -- ^ fst is the list of items for which the function returned an+  -- empty list. The forest includes all other items.+tieredForest f+  = second forest+  . groupByHead+  . sortBy (comparing snd)+  . map (\a -> (a, f a))++tree+  :: Eq b+  => b+  -> ([a], [(b, [(a, [b])])])+  -> T.Tree ([a], b)+tree lbl (as, rest) = T.Node (as, lbl) (forest rest)++forest+  :: Eq b+  => [(b, [(a, [b])])]+  -> T.Forest ([a], b)+forest = map (uncurry tree . second groupByHead)++groupByHead+  :: Eq b+  => [(a, [b])]+  -> ([a], [(b, [(a, [b])])])+groupByHead+  = second groupPairs+  . partitionEithers+  . map pluckHead++pluckHead+  :: (a, [b])+  -> Either a (b, (a, [b]))+pluckHead (a, []) = Left a+pluckHead (a, b:bs) = Right (b, (a, bs))++groupPairs+  :: Eq a+  => [(a, b)]+  -> [(a, [b])]+groupPairs+  = map (\ls -> (fst . head $ ls, map snd ls))+  . groupBy (\x y -> fst x == fst y)+

@@ -268,7 +268,11 @@       bits =         if Map.null bal         then [md "--"]-        else let mkChk e = E.bottomLineToDrCr e eo ch+        else let mkChk e = E.bottomLineToDrCr mayDc eo ch+                  where+                    mayDc = case e of+                      L.Zero -> Nothing+                      L.NonZero c -> Just $ L.colDrCr c              in fmap mkChk . elems $ bal       j = R.LeftJustify   in PreSpec j ps bits

@@ -80,12 +80,12 @@ dcToLbl L.Debit = Debit dcToLbl L.Credit = Credit -bottomLineToDrCr :: L.BottomLine -> EvenOdd -> Changers -> R.Chunk-bottomLineToDrCr bl eo chgrs = md c+bottomLineToDrCr :: Maybe L.DrCr -> EvenOdd -> Changers -> R.Chunk+bottomLineToDrCr mayDc eo chgrs = md c   where-    (c, md) = case bl of-      L.Zero -> ("--", getEvenOddLabelValue Zero eo chgrs)-      L.NonZero (L.Column clmDrCr _) -> case clmDrCr of+    (c, md) = case mayDc of+      Nothing -> ("--", getEvenOddLabelValue Zero eo chgrs)+      Just dc -> case dc of         L.Debit -> ("<", getEvenOddLabelValue Debit eo chgrs)         L.Credit -> (">", getEvenOddLabelValue Credit eo chgrs) 

@@ -14,6 +14,7 @@   , module Penny.Lincoln.Equivalent   , module Penny.Lincoln.HasText   , module Penny.Lincoln.Matchers+  , module Penny.Lincoln.Natural   , module Penny.Lincoln.PriceDb   , module Penny.Lincoln.Serial   , display@@ -26,6 +27,7 @@ import Penny.Lincoln.Equivalent import Penny.Lincoln.HasText import Penny.Lincoln.Matchers+import Penny.Lincoln.Natural import Penny.Lincoln.PriceDb import Penny.Lincoln.Serial 

@@ -51,6 +51,7 @@   , Places   , add   , mult+  , divide   , Difference(LeftBiggerBy, RightBiggerBy, Equal)   , difference   , allocate@@ -632,6 +633,16 @@  mult :: Qty -> Qty -> Qty mult (Qty xm xe) (Qty ym ye) = Qty (xm * ym) (xe + ye)+++-- | Division. There can be no division by zero errors, as a Qty is+-- never zero.  Converting to a floating-point number destroys+-- precision, so be sure this is what you want.  Sometimes it is+-- useful where precision is not needed (e.g. percentages).+divide :: Fractional a => Qty -> Qty -> a+divide q1 q2 = toFloat q1 / toFloat q2+  where+    toFloat (Qty s p) = fromIntegral s / (10 ^ p)   --

@@ -0,0 +1,22 @@+-- | Natural numbers, either positive or non-zero.  These wrap Int+-- rather than Integers so do not use them were unlimited precision is+-- needed.++module Penny.Lincoln.Natural+  ( NonNegative (unNonNegative)+  , nonNegative+  , Positive (unPositive)+  , positive+  ) where++newtype NonNegative = NonNegative { unNonNegative :: Int }+  deriving (Eq, Show, Ord)++nonNegative :: Int -> Maybe NonNegative+nonNegative i = if i >= 0 then Just (NonNegative i) else Nothing++newtype Positive = Positive { unPositive :: Int }+  deriving (Eq, Show, Ord)++positive :: Int -> Maybe Positive+positive i = if i > 0 then Just (Positive i) else Nothing

@@ -1,275 +0,0 @@--- | A nested map. The values in each NestedMap are tuples, with the--- first element of the tuple being a label that you select and the--- second value being another NestedMap. Functions are provided so you--- may query the map at any level or insert new labels (and,--- therefore, new keys) at any level.-module Penny.Steel.NestedMap (-  NestedMap ( NestedMap, unNestedMap ),-  empty,-  relabel,-  descend,-  insert,-  cumulativeTotal,-  traverse,-  traverseWithTrail,-  toForest ) where--import Control.Applicative ((<*>), (<$>))-import Data.Map ( Map )-import qualified Data.Foldable as F-import qualified Data.Traversable as T-import qualified Data.Tree as E-import qualified Data.Map as M-import Data.Monoid ( Monoid, mconcat, mappend, mempty )--newtype NestedMap k l =-  NestedMap { unNestedMap :: Map k (l, NestedMap k l) }-  deriving (Eq, Show, Ord)--instance Functor (NestedMap k) where-  fmap f (NestedMap m) = let-    g (l, s) = (f l, fmap f s)-    in NestedMap $ M.map g m--instance (Ord k) => F.Foldable (NestedMap k) where-  foldMap = T.foldMapDefault--instance (Ord k) => T.Traversable (NestedMap k) where-  -- traverse :: Applicative f-  --          => (a -> f b)-  --          -> NestedMap k a-  --          -> f (NestedMap k b)-  traverse f (NestedMap m) = let-      f' (l, m') = (,) <$> f l <*> T.traverse f m'-      in NestedMap <$> T.traverse f' m---- | An empty NestedMap.-empty :: NestedMap k l-empty = NestedMap (M.empty)---- | Helper function for relabel. For a given key and function--- that modifies the label, return the new submap to insert into the--- given map. Does not actually insert the submap though. That way,--- relabel can then modify the returned submap before--- inserting it into the mother map with the given label.-newSubmap ::-  (Ord k)-  => NestedMap k l-  -> k-  -> (Maybe l -> l)-  -> (l, NestedMap k l)-newSubmap (NestedMap m) k g = (newL, NestedMap newM) where-  (newL, newM) = case M.lookup k m of-    Nothing -> (g Nothing, M.empty)-    (Just (oldL, (NestedMap oldM))) -> (g (Just oldL), oldM)---- | Descends through a NestedMap with successive keys in the list,--- proceeding from left to right. At any given level, if the key--- given does not already exist, then inserts an empty submap and--- applies the given label modification function to Nothing to--- determine the new label. If the given key already does exist, then--- preserves the existing submap and applies the given label--- modification function to (Just oldlabel) to determine the new--- label.-relabel ::-  (Ord k)-  => NestedMap k l-  -> [(k, (Maybe l -> l))]-  -> NestedMap k l-relabel m [] = m-relabel (NestedMap m) ((k, f):vs) = let-  (newL, newM) = newSubmap (NestedMap m) k f-  newM' = relabel newM vs-  in NestedMap $ M.insert k (newL, newM') m---- | Given a list of keys, find the key that is furthest down in the--- map that matches the requested list of keys. Returns [(k, l)],--- where the first item in the list is the topmost key found and its--- matching label, and the last item in the list is the deepest key--- found and its matching label. (Often you will be most interested--- in the deepest key.)-descend ::-  Ord k-  => [k]-  -> NestedMap k l-  -> [(k, l)]-descend keys (NestedMap mi) = descend' keys mi where-  descend' [] _ = []-  descend' (k:ks) m = case M.lookup k m of-    Nothing -> []-    Just (l, (NestedMap im)) -> (k, l) : descend' ks im----- | Descends through the NestedMap one level at a time, proceeding--- key by key from left to right through the list of keys given. At--- the last key, appends the given label to the labels already--- present; if no label is present, uses mempty and mappend to create--- a new label. If the list of keys is empty, does nothing.-insert ::-  (Ord k, Monoid l)-  => NestedMap k l-  -> [k]-  -> l-  -> NestedMap k l-insert m [] _ = m-insert m ks l = relabel m ts where-  ts = firsts ++ [end]-  firsts = map (\k -> (k, keepOld)) (init ks) where-    keepOld mk = case mk of-      (Just old) -> old-      Nothing -> mempty-  end = (key, newL) where-    key = last ks-    newL mk = case mk of-      (Just old) -> old `mappend` l-      Nothing -> mempty `mappend` l--totalMap ::-  (Monoid l)-  => NestedMap k l-  -> l-totalMap (NestedMap m) =-  if M.null m-  then mempty-  else mconcat . map totalTuple . M.elems $ m--totalTuple ::-  (Monoid l)-  => (l, NestedMap k l)-  -> l-totalTuple (l, (NestedMap top)) =-  if M.null top-  then l-  else mappend l (totalMap (NestedMap top))--remapWithTotals ::-  (Monoid l)-  => NestedMap k l-  -> NestedMap k l-remapWithTotals (NestedMap top) =-  if M.null top-  then NestedMap M.empty-  else NestedMap $ M.map f top where-    f a@(_, m) = (totalTuple a, remapWithTotals m)---- | Leaves all keys of the map and submaps the same. Changes each--- label to reflect the total of that label and of all the labels of--- the maps within the NestedMap accompanying the label. Returns the--- total of the entire NestedMap.-cumulativeTotal ::-  (Monoid l)-  => NestedMap k l-  -> (l, NestedMap k l)-cumulativeTotal m = (totalMap m, remapWithTotals m)---- | Supply a function that takes a key, a label, and a--- NestedMap. traverse will traverse the NestedMap. For each (label,--- NestedMap) pair, traverse will first apply the given function to--- the label before descending through the NestedMap. The function is--- applied to the present key and label and the accompanying--- NestedMap. The function you supply must return a Maybe. If the--- result is Nothing, then the pair is deleted as a value from its--- parent NestedMap. If the result is (Just s), then the label of this--- level of the NestedMap is changed to s before descending to the--- next level of the NestedMap.------ All this is done in a monad, so you can carry out arbitrary side--- effects such as inspecting or changing a state or doing IO. If you--- don't need a monad, just use Identity.------ Thus this function can be used to inspect, modify, and prune a--- NestedMap.------ For a simpler traverse that does not provide you with so much--- information, NestedMap is also an instance of Data.Traversable.-traverse ::-  (Monad m, Ord k)-  => (k -> l -> NestedMap k l -> m (Maybe a))-  -> NestedMap k l-  -> m (NestedMap k a)-traverse f m = traverseWithTrail (\_ -> f) m---- | Like traverse, but the supplied function is also applied to a--- list that tells it about the levels of NestedMap that are parents--- to this NestedMap.-traverseWithTrail ::-  (Monad m, Ord k)-  => ( [(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a) )-  -> NestedMap k l-  -> m (NestedMap k a)-traverseWithTrail f = traverseWithTrail' f []--traverseWithTrail' ::-  (Monad m, Ord k)-  => ([(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a))-  -> [(k, l)]-  -> NestedMap k l-  -> m (NestedMap k a)-traverseWithTrail' f ts (NestedMap m) =-  if M.null m-  then return $ NestedMap M.empty-  else do-    let ps = M.assocs m-    mlsMaybes <- mapM (traversePairWithTrail f ts) ps-    let ps' = zip (M.keys m) mlsMaybes-        folder (k, ma) rs = case ma of-          (Just r) -> (k, r):rs-          Nothing -> rs-        ps'' = foldr folder [] ps'-    return (NestedMap (M.fromList ps''))--traversePairWithTrail ::-  (Monad m, Ord k)-  => ( [(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a) )-  -> [(k, l)]-  -> (k, (l, NestedMap k l))-  -> m (Maybe (a, NestedMap k a))-traversePairWithTrail f ls (k, (l, m)) = do-  ma <- f ls k l m-  case ma of-    Nothing -> return Nothing-    (Just a) -> do-      m' <- traverseWithTrail' f ((k, l):ls) m-      return (Just (a, m'))---- | Convert a NestedMap to a Forest.-toForest :: Ord k => NestedMap k l -> E.Forest (k, l)-toForest = map toNode . M.assocs . unNestedMap-  where-    toNode (k, (l, m)) = E.Node (k, l) (toForest m)---- For testing-_new :: (k, l) -> (k, (Maybe l -> l))-_new (k, l) = (k, const l)--_map1, _map2, _map3, _map4 :: NestedMap Int String-_map1 = NestedMap M.empty-_map2 = relabel _map1 [_new (5, "hello"), _new (66, "goodbye"), _new (777, "yeah")]-_map3 = relabel _map2 [_new (6, "what"), _new (77, "zeke"), _new (888, "foo")]-_map4 = relabel _map3-       [ (6, (\m -> case m of Nothing -> "_new"; (Just s) -> s ++ "_new"))-       , (77, (\m -> case m of Nothing -> "_new"; (Just s) -> s ++ "more _new")) ]--_printer :: Int -> String -> a -> IO (Maybe ())-_printer i s _ = do-  putStrLn (show i)-  putStrLn s-  return $ Just ()--_printerWithTrail :: [(Int, String)] -> Int -> String -> a -> IO (Maybe ())-_printerWithTrail ps n str _ = do-  let ptr (i, s) = putStr ("(" ++ show i ++ ", " ++ s ++ ") ")-  mapM_ ptr . reverse $ ps-  ptr (n, str)-  putStrLn ""-  return $ Just ()--_showMap4 :: IO ()-_showMap4 = do-  _ <- traverse _printer _map4-  return ()--_showMapWithTrail :: IO ()-_showMapWithTrail = do-  _ <- traverseWithTrail _printerWithTrail _map4-  return ()

@@ -1,5 +1,5 @@ Name: penny-Version: 0.24.0.0+Version: 0.26.0.0 Cabal-version: >=1.8 Build-Type: Simple License: BSD3@@ -218,6 +218,7 @@     , Penny.Cabin.Balance     , Penny.Cabin.Balance.Convert     , Penny.Cabin.Balance.Convert.Chunker+    , Penny.Cabin.Balance.Convert.ChunkerPct     , Penny.Cabin.Balance.Convert.Options     , Penny.Cabin.Balance.Convert.Parser     , Penny.Cabin.Balance.MultiCommodity@@ -260,6 +261,7 @@     , Penny.Lincoln.Equivalent     , Penny.Lincoln.HasText     , Penny.Lincoln.Matchers+    , Penny.Lincoln.Natural     , Penny.Lincoln.Predicates     , Penny.Lincoln.Predicates.Siblings     , Penny.Lincoln.PriceDb@@ -268,7 +270,6 @@     , Penny.Lincoln.Serial     , Penny.Shield     , Penny.Steel-    , Penny.Steel.NestedMap     , Penny.Steel.Sums     , Penny.Wheat     , Penny.Zinc