summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorOmariNorman <>2013-08-29 19:38:58 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-08-29 19:38:58 (GMT)
commit6c79142079bc50d65376ea6f306bb06d991233fa (patch)
tree86f27fecc508cc51fad89d0c66c99db9eb4cc706
parent89b96fbd752306acb2899fb6d35dc9bac6d75b41 (diff)
version 0.26.0.00.26.0.0
-rw-r--r--bin/penny-selloff.hs4
-rw-r--r--doc/man/penny.111
-rw-r--r--lib/Penny/Cabin/Balance/Convert.hs156
-rw-r--r--lib/Penny/Cabin/Balance/Convert/Chunker.hs5
-rw-r--r--lib/Penny/Cabin/Balance/Convert/ChunkerPct.hs254
-rw-r--r--lib/Penny/Cabin/Balance/Convert/Options.hs1
-rw-r--r--lib/Penny/Cabin/Balance/Convert/Parser.hs58
-rw-r--r--lib/Penny/Cabin/Balance/MultiCommodity.hs24
-rw-r--r--lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs5
-rw-r--r--lib/Penny/Cabin/Balance/Util.hs161
-rw-r--r--lib/Penny/Cabin/Posts/Growers.hs6
-rw-r--r--lib/Penny/Cabin/Scheme.hs10
-rw-r--r--lib/Penny/Lincoln.hs2
-rw-r--r--lib/Penny/Lincoln/Bits/Qty.hs11
-rw-r--r--lib/Penny/Lincoln/Natural.hs22
-rw-r--r--lib/Penny/Steel/NestedMap.hs275
-rw-r--r--penny.cabal5
17 files changed, 587 insertions, 423 deletions
diff --git a/bin/penny-selloff.hs b/bin/penny-selloff.hs
index b4ea902..92cfd7e 100644
--- a/bin/penny-selloff.hs
+++ b/bin/penny-selloff.hs
@@ -170,8 +170,8 @@ help pn = unlines
]
calcBalances :: [Cop.LedgerItem] -> [(L.Account, L.Balance)]
-calcBalances =
- BU.flatten
+calcBalances
+ = BU.flatten
. BU.balances (ShowZeroBalances False)
. map (\p -> ((), p))
. concatMap L.transactionToPostings
diff --git a/doc/man/penny.1 b/doc/man/penny.1
index d870cc2..c6d2b9a 100644
--- a/doc/man/penny.1
+++ b/doc/man/penny.1
@@ -726,6 +726,17 @@ Sort balances by sub-account name (default) or by quantity
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
diff --git a/lib/Penny/Cabin/Balance/Convert.hs b/lib/Penny/Cabin/Balance/Convert.hs
index 7a08dab..0bfc977 100644
--- a/lib/Penny/Cabin/Balance/Convert.hs
+++ b/lib/Penny/Cabin/Balance/Convert.hs
@@ -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.Parsers as CP
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 Penny.Shield as S
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 @@ import qualified System.Console.Rainbow as Rb
-- 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 @@ data ForestAndBL = ForestAndBL {
, _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 @@ rows (ForestAndBL f tot to) = (first:second:rest, to)
$ 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,11 +215,18 @@ report
-> [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
@@ -168,7 +239,7 @@ cmdLineReport o rt = (help o, mkMode)
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 @@ process
-> 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
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 @@ fromParsedOpts
:: 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 @@ cmpBottomLine (n1, bl1) (n2, bl2) =
qt = compare (Bal.colQty c1) (Bal.colQty c2)
na = compare n1 n2
+
------------------------------------------------------------
-- ## Help
------------------------------------------------------------
@@ -322,12 +391,17 @@ help o = unlines $
++ 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"
diff --git a/lib/Penny/Cabin/Balance/Convert/Chunker.hs b/lib/Penny/Cabin/Balance/Convert/Chunker.hs
index 102cd64..5d05d5f 100644
--- a/lib/Penny/Cabin/Balance/Convert/Chunker.hs
+++ b/lib/Penny/Cabin/Balance/Convert/Chunker.hs
@@ -227,7 +227,10 @@ balanceChunks
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
diff --git a/lib/Penny/Cabin/Balance/Convert/ChunkerPct.hs b/lib/Penny/Cabin/Balance/Convert/ChunkerPct.hs
new file mode 100644
index 0000000..6df69c1
--- /dev/null
+++ b/lib/Penny/Cabin/Balance/Convert/ChunkerPct.hs
@@ -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
+
diff --git a/lib/Penny/Cabin/Balance/Convert/Options.hs b/lib/Penny/Cabin/Balance/Convert/Options.hs
index b7d0ee1..955086b 100644
--- a/lib/Penny/Cabin/Balance/Convert/Options.hs
+++ b/lib/Penny/Cabin/Balance/Convert/Options.hs
@@ -26,6 +26,7 @@ toParserOpts d rt = P.Opts
, P.dateTime = S.currentTime rt
, P.sortOrder = sortOrder d
, P.sortBy = sortBy d
+ , P.percentRpt = Nothing
}
defaultOptions :: DefaultOpts
diff --git a/lib/Penny/Cabin/Balance/Convert/Parser.hs b/lib/Penny/Cabin/Balance/Convert/Parser.hs
index 465cf73..14818a0 100644
--- a/lib/Penny/Cabin/Balance/Convert/Parser.hs
+++ b/lib/Penny/Cabin/Balance/Convert/Parser.hs
@@ -3,6 +3,7 @@ module Penny.Cabin.Balance.Convert.Parser (
Opts(..)
, Target(..)
, SortBy(..)
+ , RoundTo(..)
, allOptSpecs
) where
@@ -17,6 +18,10 @@ import qualified System.Console.MultiArg.Combinator as C
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 @@ data Opts = Opts
, 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 @@ parseZeroBalances = fmap f P.zeroBalances
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 :: C.OptSpec (Opts -> Opts)
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) }
diff --git a/lib/Penny/Cabin/Balance/MultiCommodity.hs b/lib/Penny/Cabin/Balance/MultiCommodity.hs
index 6a5e69f..f09b245 100644
--- a/lib/Penny/Cabin/Balance/MultiCommodity.hs
+++ b/lib/Penny/Cabin/Balance/MultiCommodity.hs
@@ -19,7 +19,7 @@ import qualified Penny.Liberty as Ly
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 @@ summedSortedBalTree ::
-> (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 @@ help o = unlines
++ 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"
diff --git a/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs b/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs
index 59bcf8e..5243674 100644
--- a/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs
+++ b/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs
@@ -214,7 +214,10 @@ balanceChunks
-> (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)
diff --git a/lib/Penny/Cabin/Balance/Util.hs b/lib/Penny/Cabin/Balance/Util.hs
index 42d7988..52c443f 100644
--- a/lib/Penny/Cabin/Balance/Util.hs
+++ b/lib/Penny/Cabin/Balance/Util.hs
@@ -17,52 +17,29 @@ module Penny.Cabin.Balance.Util
, 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 @@ filterForest f = mapMaybe pruneTree
-- | 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 @@ forestWithParents = map (treeWithParentsR [])
-- 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 @@ boxesBalance
. 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 @@ longestLists as =
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)
+
diff --git a/lib/Penny/Cabin/Posts/Growers.hs b/lib/Penny/Cabin/Posts/Growers.hs
index 880ecb1..62fe402 100644
--- a/lib/Penny/Cabin/Posts/Growers.hs
+++ b/lib/Penny/Cabin/Posts/Growers.hs
@@ -268,7 +268,11 @@ getTotalDrCr ch i =
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
diff --git a/lib/Penny/Cabin/Scheme.hs b/lib/Penny/Cabin/Scheme.hs
index c087b3a..176c67d 100644
--- a/lib/Penny/Cabin/Scheme.hs
+++ b/lib/Penny/Cabin/Scheme.hs
@@ -80,12 +80,12 @@ dcToLbl :: L.DrCr -> Label
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)
diff --git a/lib/Penny/Lincoln.hs b/lib/Penny/Lincoln.hs
index 6423b8d..0ff194d 100644
--- a/lib/Penny/Lincoln.hs
+++ b/lib/Penny/Lincoln.hs
@@ -14,6 +14,7 @@ module Penny.Lincoln
, 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.Builders
import Penny.Lincoln.Equivalent
import Penny.Lincoln.HasText
import Penny.Lincoln.Matchers
+import Penny.Lincoln.Natural
import Penny.Lincoln.PriceDb
import Penny.Lincoln.Serial
diff --git a/lib/Penny/Lincoln/Bits/Qty.hs b/lib/Penny/Lincoln/Bits/Qty.hs
index 98e629f..508b2b4 100644
--- a/lib/Penny/Lincoln/Bits/Qty.hs
+++ b/lib/Penny/Lincoln/Bits/Qty.hs
@@ -51,6 +51,7 @@ module Penny.Lincoln.Bits.Qty
, Places
, add
, mult
+ , divide
, Difference(LeftBiggerBy, RightBiggerBy, Equal)
, difference
, allocate
@@ -634,6 +635,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)
+
+
--
-- Allocation
--
diff --git a/lib/Penny/Lincoln/Natural.hs b/lib/Penny/Lincoln/Natural.hs
new file mode 100644
index 0000000..2f452f3
--- /dev/null
+++ b/lib/Penny/Lincoln/Natural.hs
@@ -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
diff --git a/lib/Penny/Steel/NestedMap.hs b/lib/Penny/Steel/NestedMap.hs
deleted file mode 100644
index d3bde09..0000000
--- a/lib/Penny/Steel/NestedMap.hs
+++ /dev/null
@@ -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 ()
diff --git a/penny.cabal b/penny.cabal
index c188b5f..33ed60b 100644
--- a/penny.cabal
+++ b/penny.cabal
@@ -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 @@ Library
, 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 @@ Library
, 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 @@ Library
, Penny.Lincoln.Serial
, Penny.Shield
, Penny.Steel
- , Penny.Steel.NestedMap
, Penny.Steel.Sums
, Penny.Wheat
, Penny.Zinc