summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorOmariNorman <>2013-08-25 15:03:48 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-08-25 15:03:48 (GMT)
commit89b96fbd752306acb2899fb6d35dc9bac6d75b41 (patch)
treeaaeae417b58c2d5b7ab32d2a19124e6a284f3609
version 0.24.0.00.24.0.0
-rw-r--r--LICENSE31
-rw-r--r--README43
-rw-r--r--Setup.hs2
-rw-r--r--bin/penny-diff.hs195
-rw-r--r--bin/penny-main.hs286
-rw-r--r--bin/penny-reconcile.hs76
-rw-r--r--bin/penny-reprint.hs52
-rw-r--r--bin/penny-selloff.hs621
-rw-r--r--doc/dependencies.dot26
-rw-r--r--doc/examples/more-file-format-details.pny167
-rw-r--r--doc/examples/starter.pny258
-rw-r--r--doc/examples/stocks-realized.pny14
-rw-r--r--doc/examples/stocks.pny246
-rw-r--r--doc/man/penny-basics.7372
-rw-r--r--doc/man/penny-commodities.7199
-rw-r--r--doc/man/penny-custom.763
-rw-r--r--doc/man/penny-diff.155
-rw-r--r--doc/man/penny-examples.7107
-rw-r--r--doc/man/penny-fit.7375
-rw-r--r--doc/man/penny-reconcile.1100
-rw-r--r--doc/man/penny-reprint.153
-rw-r--r--doc/man/penny-selloff.185
-rw-r--r--doc/man/penny-suite.7136
-rw-r--r--doc/man/penny.1815
-rw-r--r--doc/penny-fit-sample.hs181
-rwxr-xr-xinstall-docs59
-rw-r--r--lib/Penny.hs569
-rw-r--r--lib/Penny/Brenner.hs255
-rw-r--r--lib/Penny/Brenner/Clear.hs185
-rw-r--r--lib/Penny/Brenner/Database.hs40
-rw-r--r--lib/Penny/Brenner/Import.hs140
-rw-r--r--lib/Penny/Brenner/Info.hs135
-rw-r--r--lib/Penny/Brenner/Merge.hs370
-rw-r--r--lib/Penny/Brenner/OFX.hs72
-rw-r--r--lib/Penny/Brenner/Print.hs57
-rw-r--r--lib/Penny/Brenner/Types.hs340
-rw-r--r--lib/Penny/Brenner/Util.hs106
-rw-r--r--lib/Penny/Cabin.hs7
-rw-r--r--lib/Penny/Cabin/Balance.hs21
-rw-r--r--lib/Penny/Cabin/Balance/Convert.hs335
-rw-r--r--lib/Penny/Cabin/Balance/Convert/Chunker.hs240
-rw-r--r--lib/Penny/Cabin/Balance/Convert/Options.hs39
-rw-r--r--lib/Penny/Cabin/Balance/Convert/Parser.hs87
-rw-r--r--lib/Penny/Cabin/Balance/MultiCommodity.hs168
-rw-r--r--lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs224
-rw-r--r--lib/Penny/Cabin/Balance/MultiCommodity/Parser.hs29
-rw-r--r--lib/Penny/Cabin/Balance/Util.hs233
-rw-r--r--lib/Penny/Cabin/Interface.hs84
-rw-r--r--lib/Penny/Cabin/Meta.hs13
-rw-r--r--lib/Penny/Cabin/Options.hs16
-rw-r--r--lib/Penny/Cabin/Parsers.hs24
-rw-r--r--lib/Penny/Cabin/Posts.hs585
-rw-r--r--lib/Penny/Cabin/Posts/Allocated.hs402
-rw-r--r--lib/Penny/Cabin/Posts/BottomRows.hs649
-rw-r--r--lib/Penny/Cabin/Posts/Chunk.hs150
-rw-r--r--lib/Penny/Cabin/Posts/Fields.hs199
-rw-r--r--lib/Penny/Cabin/Posts/Growers.hs603
-rw-r--r--lib/Penny/Cabin/Posts/Meta.hs83
-rw-r--r--lib/Penny/Cabin/Posts/Parser.hs286
-rw-r--r--lib/Penny/Cabin/Posts/Spacers.hs32
-rw-r--r--lib/Penny/Cabin/Posts/Types.hs4
-rw-r--r--lib/Penny/Cabin/Row.hs140
-rw-r--r--lib/Penny/Cabin/Scheme.hs142
-rw-r--r--lib/Penny/Cabin/Scheme/Schemes.hs87
-rw-r--r--lib/Penny/Cabin/TextFormat.hs173
-rw-r--r--lib/Penny/Copper.hs232
-rw-r--r--lib/Penny/Copper/Interface.hs49
-rw-r--r--lib/Penny/Copper/Parsec.hs567
-rw-r--r--lib/Penny/Copper/Render.hs512
-rw-r--r--lib/Penny/Copper/Terminals.hs145
-rw-r--r--lib/Penny/Liberty.hs776
-rw-r--r--lib/Penny/Lincoln.hs77
-rw-r--r--lib/Penny/Lincoln/Balance.hs116
-rw-r--r--lib/Penny/Lincoln/Bits.hs164
-rw-r--r--lib/Penny/Lincoln/Bits/DateTime.hs157
-rw-r--r--lib/Penny/Lincoln/Bits/Open.hs162
-rw-r--r--lib/Penny/Lincoln/Bits/Price.hs52
-rw-r--r--lib/Penny/Lincoln/Bits/Qty.hs794
-rw-r--r--lib/Penny/Lincoln/Builders.hs28
-rw-r--r--lib/Penny/Lincoln/Ents.hs261
-rw-r--r--lib/Penny/Lincoln/Equivalent.hs50
-rw-r--r--lib/Penny/Lincoln/HasText.hs58
-rw-r--r--lib/Penny/Lincoln/Matchers.hs21
-rw-r--r--lib/Penny/Lincoln/Predicates.hs323
-rw-r--r--lib/Penny/Lincoln/Predicates/Siblings.hs327
-rw-r--r--lib/Penny/Lincoln/PriceDb.hs99
-rw-r--r--lib/Penny/Lincoln/Queries.hs108
-rw-r--r--lib/Penny/Lincoln/Queries/Siblings.hs102
-rw-r--r--lib/Penny/Lincoln/Serial.hs126
-rw-r--r--lib/Penny/Shield.hs106
-rw-r--r--lib/Penny/Steel.hs3
-rw-r--r--lib/Penny/Steel/NestedMap.hs275
-rw-r--r--lib/Penny/Steel/Sums.hs78
-rw-r--r--lib/Penny/Wheat.hs266
-rw-r--r--lib/Penny/Zinc.hs746
-rw-r--r--penny.cabal476
-rw-r--r--tests/Copper.hs8
-rw-r--r--tests/Copper/Gen/Parsers.hs821
-rw-r--r--tests/Copper/Gen/Terminals.hs151
-rw-r--r--tests/Copper/Parser.hs305
-rw-r--r--tests/Copper/Render.hs177
-rw-r--r--tests/Lincoln.hs927
-rw-r--r--tests/penny-gibberish.hs73
-rw-r--r--tests/penny-test.hs50
104 files changed, 21709 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..521b499
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,31 @@
+Copyright (c) 2011-2013 Omari Norman.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in
+ the documentation and/or other materials provided with the
+ distribution.
+
+ * Neither the name of Omari Norman nor the names of contributors
+ to this software may be used to endorse or promote products
+ derived from this software without specific prior written
+ permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README b/README
new file mode 100644
index 0000000..e24ae39
--- /dev/null
+++ b/README
@@ -0,0 +1,43 @@
+Welcome to Penny, double-entry accounting.
+
+Penny's web pages are at:
+
+http://massysett.github.com/penny
+http://hackage.haskell.org/package/penny
+http://github.com/massysett/penny
+
+Versions that contain at least one odd number are development
+versions. They are not posted to Hackage. I try to keep the master
+branch in compilable shape. However, development versions may not pass
+all tests, and in particular they may have out of date or incomplete
+documentation.
+
+Releases consist of code of reasonable quality. All of the groups in
+their release numbers are even.
+
+Penny is licensed under the MIT license, see the LICENSE file.
+
+To install the latest release, "cabal install penny" should work. To
+also build test executables, run "cabal install -ftest penny". That
+will give you two additional executables: penny-test, which when run
+will test a bunch of QuickCheck properties, and penny-gibberish, which
+prints a random, but valid, ledger file.
+
+To install the manual pages and the documentation, run "sh
+install-docs". It will install the manual pages to $PREFIX/share/man
+and the other documentation to $PREFIX/share/doc/penny. By default
+$PREFIX is /usr/local; you can change this by editing the
+install-docs file and changing the "PREFIX" variable.
+
+To remove the manual pages and the documentation, run "sh
+install-docs remove."
+
+The first thing you will want to look at is the manual page
+penny-basics(7). Then you will want to examine the starter.pny file
+in the examples directory, which will show you how to write a ledger
+file. penny-suite(7) will then direct you to other documentation that
+may interest you.
+
+Though I do use this program to maintain all my financial records, it
+is still relatively new and no one but me has tested it. Use at your
+own risk.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/bin/penny-diff.hs b/bin/penny-diff.hs
new file mode 100644
index 0000000..e9a07f8
--- /dev/null
+++ b/bin/penny-diff.hs
@@ -0,0 +1,195 @@
+module Main where
+
+import Control.Arrow (first, second)
+import Data.Maybe (fromJust)
+import Data.List (deleteFirstsBy)
+import qualified System.Console.MultiArg as M
+import qualified Penny.Liberty as Ly
+import qualified Penny.Lincoln as L
+import Penny.Lincoln ((==~))
+import qualified Penny.Copper as C
+import qualified Penny.Copper.Render as CR
+import qualified Penny.Steel.Sums as S
+import Data.Maybe (mapMaybe)
+import qualified Data.Text as X
+import qualified Data.Text.IO as TIO
+import qualified System.Exit as E
+import qualified System.IO as IO
+
+import qualified Paths_penny as PPB
+
+main :: IO ()
+main = runPennyDiff
+
+help :: String -> String
+help pn = unlines
+ [ "usage: " ++ pn ++ " [-12] FILE1 FILE2"
+ , "Shows items that exist in FILE1 but not in FILE2,"
+ , "as well as items that exist in FILE2 but not in FILE1."
+ , "Options:"
+ , "-1 Show only items that exist in FILE1 but not in FILE2"
+ , "-2 Show only items that exist in FILE2 but not in FILE1"
+ , ""
+ , "--help, -h - show this help and exit"
+ , "--version Show version and exit"
+ ]
+
+data Args = ArgFile File | Filename String
+ deriving (Eq, Show)
+
+data DiffsToShow = File1Only | File2Only | BothFiles
+
+optFile1 :: M.OptSpec Args
+optFile1 = M.OptSpec [] "1" (M.NoArg (ArgFile File1))
+
+optFile2 :: M.OptSpec Args
+optFile2 = M.OptSpec [] "2" (M.NoArg (ArgFile File2))
+
+allOpts :: [M.OptSpec Args]
+allOpts = [ optFile1 , optFile2 ]
+
+data File = File1 | File2
+ deriving (Eq, Show)
+
+-- | All possible items, but excluding blank lines.
+type NonBlankItem =
+ S.S3 L.Transaction L.PricePoint C.Comment
+
+removeMeta
+ :: L.Transaction
+ -> (L.TopLineCore, L.Ents L.PostingCore)
+removeMeta
+ = first L.tlCore
+ . second (fmap L.pdCore)
+ . L.unTransaction
+
+clonedNonBlankItem :: NonBlankItem -> NonBlankItem -> Bool
+clonedNonBlankItem nb1 nb2 = case (nb1, nb2) of
+ (S.S3a t1, S.S3a t2) -> removeMeta t1 ==~ removeMeta t2
+ (S.S3b p1, S.S3b p2) -> p1 ==~ p2
+ (S.S3c c1, S.S3c c2) -> c1 == c2
+ _ -> False
+
+toNonBlankItem :: C.LedgerItem -> Maybe NonBlankItem
+toNonBlankItem = S.caseS4 (Just . S.S3a) (Just . S.S3b) (Just . S.S3c)
+ (const Nothing)
+
+showLineNum :: File -> Int -> X.Text
+showLineNum f i = X.pack ("\n" ++ arrow ++ " " ++ show i ++ "\n")
+ where
+ arrow = case f of
+ File1 -> "<=="
+ File2 -> "==>"
+
+
+-- | Renders a transaction, along with a line showing what file it
+-- came from and its line number. If there is a TransactionMemo, shows
+-- the line number for the top line for that; otherwise, shows the
+-- line number for the TopLine.
+renderTransaction
+ :: File
+ -> L.Transaction
+ -> Maybe X.Text
+renderTransaction f t = fmap addHeader $ CR.transaction Nothing (noMeta t)
+ where
+ lin = case L.tMemo . L.tlCore . fst . L.unTransaction $ t of
+ Nothing -> L.unTopLineLine . L.tTopLineLine . fromJust
+ . L.tlFileMeta . fst . L.unTransaction $ t
+ Just _ -> L.unTopMemoLine . fromJust . L.tTopMemoLine . fromJust
+ . L.tlFileMeta . fst . L.unTransaction $ t
+ addHeader x = (showLineNum f lin) `X.append` x
+ noMeta txn = let (tl, es) = L.unTransaction txn
+ in (L.tlCore tl, fmap L.pdCore es)
+
+renderPrice :: File -> L.PricePoint -> Maybe X.Text
+renderPrice f p = fmap addHeader $ CR.price p
+ where
+ lin = L.unPriceLine . fromJust . L.priceLine $ p
+ addHeader x = (showLineNum f lin) `X.append` x
+
+renderNonBlankItem
+ :: File
+ -> NonBlankItem
+ -> Maybe X.Text
+renderNonBlankItem f =
+ S.caseS3 (renderTransaction f) (renderPrice f) CR.comment
+
+runPennyDiff :: IO ()
+runPennyDiff = do
+ (f1, f2, dts) <- parseCommandLine
+ l1 <- C.open [f1]
+ l2 <- C.open [f2]
+ let (r1, r2) = doDiffs l1 l2
+ showDiffs dts (r1, r2)
+ case (r1, r2) of
+ ([], []) -> E.exitSuccess
+ _ -> E.exitWith (E.ExitFailure 1)
+
+showDiffs
+ :: DiffsToShow
+ -> ([NonBlankItem], [NonBlankItem])
+ -> IO ()
+showDiffs dts (l1, l2) =
+ case dts of
+ File1Only -> showFile1
+ File2Only -> showFile2
+ BothFiles -> showFile1 >> showFile2
+ where
+ showFile1 = showNonBlankItems File1 l1
+ showFile2 = showNonBlankItems File2 l2
+
+failure :: String -> IO a
+failure s = IO.hPutStrLn IO.stderr s
+ >> E.exitWith (E.ExitFailure 2)
+
+showNonBlankItems
+ :: File
+ -> [NonBlankItem]
+ -> IO ()
+showNonBlankItems f ls =
+ mapM_ (showNonBlankItem f) ls
+
+showNonBlankItem
+ :: File
+ -> NonBlankItem
+ -> IO ()
+showNonBlankItem f nbi = maybe e TIO.putStr
+ (renderNonBlankItem f nbi)
+ where
+ e = failure $ "could not render item: " ++ show nbi
+
+
+-- | Returns a pair p, where fst p is the items that appear in file1
+-- but not in file2, and snd p is items that appear in file2 but not
+-- in file1.
+doDiffs
+ :: [C.LedgerItem]
+ -> [C.LedgerItem]
+ -> ([NonBlankItem], [NonBlankItem])
+doDiffs l1 l2 = (r1, r2)
+ where
+ mkNbList = mapMaybe toNonBlankItem
+ (nb1, nb2) = (mkNbList l1, mkNbList l2)
+ df = deleteFirstsBy clonedNonBlankItem
+ (r1, r2) = (nb1 `df` nb2, nb2 `df` nb1)
+
+-- | Returns a tuple with the first filename, the second filename, and
+-- an indication of which differences to show.
+parseCommandLine :: IO (String, String, DiffsToShow)
+parseCommandLine = do
+ as <- M.simpleHelpVersion help (Ly.version PPB.version)
+ allOpts M.Intersperse
+ (return . Filename)
+ let toFilename a = case a of
+ Filename s -> Just s
+ _ -> Nothing
+ (fn1, fn2) <- case mapMaybe toFilename as of
+ x:y:[] -> return (x, y)
+ _ -> failure "penny-diff: error: you must supply two filenames."
+ let getDiffs
+ | ((ArgFile File1) `elem` as)
+ && ((ArgFile File2) `elem` as) = BothFiles
+ | ((ArgFile File1) `elem` as) = File1Only
+ | ((ArgFile File2) `elem` as) = File2Only
+ | otherwise = BothFiles
+ return (fn1, fn2, getDiffs)
diff --git a/bin/penny-main.hs b/bin/penny-main.hs
new file mode 100644
index 0000000..c0d5bd9
--- /dev/null
+++ b/bin/penny-main.hs
@@ -0,0 +1,286 @@
+module Main where
+
+import Penny
+import qualified Paths_penny as PPB
+
+-- | This type contains settings for all the reports, as well as
+-- default settings for the global options. Some of these can be
+-- overridden on the command line.
+defaults :: Runtime -> Defaults
+defaults rt = Defaults
+ { caseSensitive = False
+ -- ^ Whether the matcher is case sensitive by default
+
+ , matcher = Within
+ -- ^ Which matcher to use. Your choices:
+ -- Within
+ -- Exact
+ -- TDFA (regular expressions, POSIX semantics)
+ -- PCRE (regular expressions, PCRE semantics)
+
+ , colorToFile = False
+ -- ^ Use colors when standard output is not a terminal?
+
+ , expressionType = Infix
+ -- ^ Use Infix or RPN expressions for the posting filters and for
+ -- the filters in the Postings report? Change to @RPN@ if you like
+ -- that kind of thing (I find RPN easier to enter; if you're not
+ -- familiar with it, you might become a convert.)
+
+ , defaultScheme = Just schemeDark
+ -- ^ Default color scheme. If Nothing, there is no default color
+ -- scheme. If there is no default color scheme and the user does
+ -- not pick one on the command line, no colors will be used.
+
+ , additionalSchemes = [schemeDark, schemeLight, schemePlain]
+ -- ^ Additional color schemes the user can pick from on the
+ -- command line.
+
+ , sorter = [(Date, Ascending)]
+ -- ^ Postings are sorted in this order by default. For example, if
+ -- the first pair is (Date, Ascending), then postings are first
+ -- sorted by date in ascending order. If the second pair is
+ -- (Payee, Ascending), then postings with the same date are then
+ -- sorted by payee.
+ --
+ -- If this list is empty, then by default postings are left in the
+ -- same order as they appear in the ledger files.
+
+ , formatQty = qtyFormatter $ S3a Period
+ -- ^ How to format quantities. This affects only quantities that
+ -- are not parsed from the ledger. Examples include calculated
+ -- totals and inferred quantities. Affects all reports.
+
+ , balanceShowZeroBalances = False
+ -- ^ Show zero balances in the balance report? If True, show them;
+ -- if False, hide them.
+
+ , balanceOrder = Ascending
+ -- ^ Whether to sort the accounts in ascending or descending order
+ -- by account name in the balance report. Your choices: Ascending
+ -- or Descending.
+
+ , convertShowZeroBalances = False
+ -- ^ Show zero balances in the convert report? If True, show them;
+ -- if False, hide them.
+
+ , convertTarget = AutoTarget
+ -- ^ The commodity to which to convert the commodities in the
+ -- convert report. Your choices:
+ --
+ -- AutoTarget - selects a target commodity automatically, based on
+ -- which commodity is the most common target commodity in the
+ -- prices in your ledger files. If there is a tie for most common
+ -- target commodity, the target that appears later in your ledger
+ -- files is used.
+ --
+ -- ManualTarget CMDTY_NAME - always use the given commodity.
+
+ , convertOrder = Ascending
+ -- ^ Sort the convert report in ascending or descending order.
+
+ , convertSortBy = SortByName
+ -- ^ Sort by account or by quantity in the convert report. Your
+ -- choices:
+ --
+ -- SortByQty
+ -- SortByName
+
+ , postingsFields = fields
+ -- ^ Fields to show by default in the postings report.
+
+ , postingsWidth = widthFromRuntime rt
+ -- ^ The postings report is roughly this wide by default. Use
+ -- @widthFromRuntime rt@ if you want to use the current width of
+ -- your terminal.
+
+ , postingsShowZeroBalances = False
+ -- ^ Show zero balances in the postings report? If True, show
+ -- them; if False, hide them.
+
+ , postingsDateFormat = yearMonthDay
+ -- ^ How to format dates in the postings report.
+
+ , postingsSubAccountLength = 2
+ -- ^ Account names in the postings report are shortened if
+ -- necessary in order to help the report fit within the allotted
+ -- width (see postingsWidth). Account names are only shortened as
+ -- much as is necessary for them to fit; however, each sub-account
+ -- name will not be shortened any more than the amount given here.
+ --
+ -- This number should be a non-negative integer.
+
+ , postingsPayeeAllocation = 40
+ -- ^ postingsPayeeAllocation and postingsAccountAllocation
+ -- determine how much space is allotted to the payee and account
+ -- fields in the postings report. These fields are variable
+ -- width. After space for most other fields is allotted, space is
+ -- allotted for these two fields. The two fields divide the space
+ -- proportionally depending on postingsPayeeAllocation and
+ -- postingsAccountAllocation. For example, if
+ -- postingsPayeeAllocation is 60 and postingsAccountAllocation is
+ -- 40, then the payee field gets 60 percent of the leftover space
+ -- and the account field gets 40 percent of the leftover space.
+ --
+ -- Both postingsPayeeAllocation and postingsAccountAllocation
+ -- must be positive integers; if either one is less than 1, your
+ -- program will crash at runtime.
+
+ , postingsAccountAllocation = 60
+ -- ^ See postingsPayeeAllocation above for an explanation
+
+ , postingsSpacers = spacers
+ -- ^ Determines the number of spaces that appears to the right of
+ -- each named field; for example, sPayee indicates how many spaces
+ -- will appear to the right of the payee field. Each field of the
+ -- Spacers should be a non-negative integer (although currently
+ -- the absolute value of the field is taken.)
+ }
+
+-- | Controls which fields appear in the report by default.
+fields :: Fields Bool
+fields = Fields
+ { fGlobalTransaction = False
+ , fRevGlobalTransaction = False
+ , fGlobalPosting = False
+ , fRevGlobalPosting = False
+ , fFileTransaction = False
+ , fRevFileTransaction = False
+ , fFilePosting = False
+ , fRevFilePosting = False
+ , fFiltered = False
+ , fRevFiltered = False
+ , fSorted = False
+ , fRevSorted = False
+ , fVisible = False
+ , fRevVisible = False
+ , fLineNum = False
+ , fDate = True
+ , fFlag = False
+ , fNumber = False
+ , fPayee = True
+ , fAccount = True
+ , fPostingDrCr = True
+ , fPostingCmdty = True
+ , fPostingQty = True
+ , fTotalDrCr = True
+ , fTotalCmdty = True
+ , fTotalQty = True
+ , fTags = False
+ , fMemo = False
+ , fFilename = False
+ }
+
+-- | Controls how many spaces appear to the right of each named field.
+spacers :: Spacers Int
+spacers = Spacers
+ { sGlobalTransaction = 1
+ , sRevGlobalTransaction = 1
+ , sGlobalPosting = 1
+ , sRevGlobalPosting = 1
+ , sFileTransaction = 1
+ , sRevFileTransaction = 1
+ , sFilePosting = 1
+ , sRevFilePosting = 1
+ , sFiltered = 1
+ , sRevFiltered = 1
+ , sSorted = 1
+ , sRevSorted = 1
+ , sVisible = 1
+ , sRevVisible = 1
+ , sLineNum = 1
+ , sDate = 1
+ , sFlag = 1
+ , sNumber = 1
+ , sPayee = 4
+ , sAccount = 1
+ , sPostingDrCr = 1
+ , sPostingCmdty = 1
+ , sPostingQty = 1
+ , sTotalDrCr = 1
+ , sTotalCmdty = 1
+ }
+
+-- | The light color scheme. You can change various values below to
+-- affect the color scheme.
+schemeLight :: Scheme
+schemeLight = Scheme "light" "for light background terminals"
+ lightLabels
+
+lightLabels :: Labels (EvenAndOdd (Chunk -> Chunk))
+lightLabels = Labels
+ { debit = EvenAndOdd { eoEven = lightDebit lightEvenTextSpec
+ , eoOdd = lightDebit lightOddTextSpec }
+ , credit = EvenAndOdd { eoEven = lightCredit lightEvenTextSpec
+ , eoOdd = lightCredit lightOddTextSpec }
+ , zero = EvenAndOdd { eoEven = lightZero lightEvenTextSpec
+ , eoOdd = lightZero lightOddTextSpec }
+ , other = EvenAndOdd { eoEven = lightEvenTextSpec
+ , eoOdd = lightOddTextSpec }
+ }
+
+lightEvenTextSpec :: Chunk -> Chunk
+lightEvenTextSpec = id
+
+lightOddTextSpec :: Chunk -> Chunk
+lightOddTextSpec = (<> (c8_b_default <> c256_b_255))
+
+lightDebit :: (Chunk -> Chunk) -> Chunk -> Chunk
+lightDebit f c = f c <> c8_f_magenta <> c256_f_52
+
+lightCredit :: (Chunk -> Chunk) -> Chunk -> Chunk
+lightCredit f c = f c <> c8_f_cyan <> c256_f_21
+
+lightZero :: (Chunk -> Chunk) -> Chunk -> Chunk
+lightZero f c = f c <> c8_f_black <> c256_f_0
+
+-- | The dark color scheme. You can change various values below to
+-- affect the color scheme.
+schemeDark :: Scheme
+schemeDark = Scheme "dark" "for dark background terminals"
+ darkLabels
+
+darkLabels :: Labels (EvenAndOdd (Chunk -> Chunk))
+darkLabels = Labels
+ { debit = EvenAndOdd { eoEven = darkDebit darkEvenTextSpec
+ , eoOdd = darkDebit darkOddTextSpec }
+ , credit = EvenAndOdd { eoEven = darkCredit darkEvenTextSpec
+ , eoOdd = darkCredit darkOddTextSpec }
+ , zero = EvenAndOdd { eoEven = darkZero darkEvenTextSpec
+ , eoOdd = darkZero darkOddTextSpec }
+ , other = EvenAndOdd { eoEven = darkEvenTextSpec
+ , eoOdd = darkOddTextSpec }
+ }
+
+darkEvenTextSpec :: Chunk -> Chunk
+darkEvenTextSpec = id
+
+darkOddTextSpec :: Chunk -> Chunk
+darkOddTextSpec = (<> (c8_b_default <> c256_b_235))
+
+darkDebit :: (Chunk -> Chunk) -> Chunk -> Chunk
+darkDebit f c = f c <> c8_f_magenta <> c256_f_208
+
+darkCredit :: (Chunk -> Chunk) -> Chunk -> Chunk
+darkCredit f c = f c <> c8_f_cyan <> c256_f_45
+
+darkZero :: (Chunk -> Chunk) -> Chunk -> Chunk
+darkZero f c = f c <> c8_f_white <> c256_f_15
+
+
+-- | Plain scheme has no colors at all.
+schemePlain :: Scheme
+schemePlain = Scheme "plain" "uses default terminal colors"
+ plainLabels
+
+plainLabels :: Labels (EvenAndOdd (Chunk -> Chunk))
+plainLabels = Labels
+ { debit = EvenAndOdd id id
+ , credit = EvenAndOdd id id
+ , zero = EvenAndOdd id id
+ , other = EvenAndOdd id id
+ }
+
+main :: IO ()
+main = runPenny PPB.version defaults
+
diff --git a/bin/penny-reconcile.hs b/bin/penny-reconcile.hs
new file mode 100644
index 0000000..aef06ea
--- /dev/null
+++ b/bin/penny-reconcile.hs
@@ -0,0 +1,76 @@
+module Main where
+
+import Data.Either (partitionEithers)
+import Data.Maybe (fromMaybe, fromJust)
+import qualified Data.Text as X
+import Control.Monad (guard)
+import qualified Penny.Copper as C
+import qualified Penny.Lincoln as L
+import qualified Penny.Liberty as Ly
+import qualified Penny.Steel.Sums as S
+import qualified System.Console.MultiArg as MA
+import qualified Paths_penny as PPB
+
+
+-- | Changes a posting to mark it reconciled, if it was already marked
+-- as cleared.
+changePosting :: L.PostingData -> L.PostingData
+changePosting p = fromMaybe p $ do
+ let c = L.pdCore p
+ fl <- L.pFlag c
+ guard (L.unFlag fl == X.singleton 'C')
+ let fl' = L.Flag . X.singleton $ 'R'
+ c' = c { L.pFlag = Just fl' }
+ return p { L.pdCore = c' }
+
+-- | Changes a TopLine to mark it as reconciled, if it was already
+-- marked as cleared.
+changeTopLine :: L.TopLineData -> L.TopLineData
+changeTopLine t = fromMaybe t $ do
+ let c = L.tlCore t
+ fl <- L.tFlag c
+ guard (L.unFlag fl == X.singleton 'C')
+ let fl' = L.Flag . X.singleton $ 'R'
+ c' = c { L.tFlag = Just fl' }
+ return t { L.tlCore = c' }
+
+changeTransaction :: L.Transaction -> L.Transaction
+changeTransaction (L.Transaction (tl, es)) =
+ L.Transaction (changeTopLine tl, fmap changePosting es)
+
+help :: String -> String
+help pn = unlines
+ [ "usage: " ++ pn ++ " [options] FILE..."
+ , "Finds all transactions and postings bearing a \"C\" flag"
+ , "and changes them to a \"R\" flag in the listed FILEs."
+ , "If no FILE, or if FILE is -, read standard input."
+ , ""
+ , "Output is printed to standard output. Input files are not"
+ , "changed."
+ , ""
+ , "Options:"
+ , " --output FILENAME, -o FILENAME"
+ , " send output to FILENAME rather than standard output"
+ , " (multiple -o options are allowed; use \"-\" for standard"
+ , " output)"
+ , " -h, --help - Show help and exit."
+ , " --version - Show version and exit"
+ ]
+
+type Printer = X.Text -> IO ()
+type PosArg = String
+type Arg = Either Printer PosArg
+
+allOpts :: [MA.OptSpec Arg]
+allOpts = [ fmap Left Ly.output ]
+
+main :: IO ()
+main = do
+ as <- MA.simpleHelpVersion help (Ly.version PPB.version)
+ allOpts MA.Intersperse (return . Right)
+ let (printers, posArgs) = partitionEithers as
+ led <- C.open posArgs
+ let led' = map (S.mapS4 changeTransaction id id id) led
+ rend = fromJust $ mapM (C.item Nothing) (map C.stripMeta led')
+ let txt = X.concat rend in txt `seq` (Ly.processOutput printers txt)
+
diff --git a/bin/penny-reprint.hs b/bin/penny-reprint.hs
new file mode 100644
index 0000000..63eff48
--- /dev/null
+++ b/bin/penny-reprint.hs
@@ -0,0 +1,52 @@
+module Main where
+
+import Data.Either (partitionEithers)
+import qualified Penny.Copper as C
+import qualified Penny.Copper.Render as R
+import qualified Penny.Liberty as Ly
+import qualified Data.Text as X
+import qualified System.Console.MultiArg as MA
+
+import qualified Paths_penny as PPB
+
+help :: String -> String
+help pn = unlines
+ [ "usage: " ++ pn ++ " FILE..."
+ , "Tidies the formatting of a Penny ledger file."
+ , "All memos, comments, and blank lines are preserved,"
+ , "and the order of the transactions and postings is not changed."
+ , "However, the whitespace that separates different elements"
+ , "of a posting will change in order to tidy things up."
+ , ""
+ , "If no FILE, or if FILE is \"-\", read stanard input."
+ , "Result is printed to standard output."
+ , ""
+ , "Options:"
+ , " --output FILENAME, -o FILENAME"
+ , " send output to FILENAME rather than standard output"
+ , " (multiple -o options are allowed; use \"-\" for standard"
+ , " output)"
+ , " --help, -h - show help and exit"
+ , " --version - show version and exit"
+ ]
+
+type Printer = X.Text -> IO ()
+type PosArg = String
+
+type Arg = Either Printer PosArg
+
+allOpts :: [MA.OptSpec Arg]
+allOpts = [ fmap Left Ly.output ]
+
+main :: IO ()
+main = do
+ as <- MA.simpleHelpVersion help (Ly.version PPB.version)
+ allOpts MA.Intersperse
+ (return . Right)
+ let (printers, posArgs) = partitionEithers as
+ l <- C.open posArgs
+ case mapM (R.item Nothing) (map C.stripMeta l) of
+ Nothing -> error "could not render final ledger."
+ Just x ->
+ let txt = X.concat x
+ in txt `seq` (Ly.processOutput printers txt)
diff --git a/bin/penny-selloff.hs b/bin/penny-selloff.hs
new file mode 100644
index 0000000..b4ea902
--- /dev/null
+++ b/bin/penny-selloff.hs
@@ -0,0 +1,621 @@
+-- | penny-selloff
+
+-- Steps
+
+-- * In IO monad: read values given on command line.
+
+-- * Parse command line. Fails if command line fails to parse.
+
+-- * If help is requested, show help and exit successfully.
+
+-- * In IO monad: read text of files given on command line. Fails if
+-- there is an IO failure.
+
+-- * Parse files given on command line. Fails if files fail to parse.
+
+-- * Calculate balances of all accounts. Remove zero balances. This
+-- step never fails.
+
+-- * Find Proceeds account specified on command line. Split it into a
+-- group name (the second sub-account) and a selloff label (the third
+-- sub-account). Obtain the SelloffStockAmt, which is the debit
+-- balance, and the SelloffCurrencyAmt, which is the credit
+-- balance. Fails if the Proceeds account does not have exactly three
+-- sub-accounts, or if the account does not have a balance with
+-- exactly one debit balance and exactly one credit balance. Returns a
+-- record with the group name, the selloff label, the selloff currency
+-- amount, and the selloff stock amount. (Remember, an amount is a Qty
+-- and a Commodity.)
+
+-- * Filter account balances to find all Basis accounts with a
+-- matching group name. Only accounts that have Basis as the first
+-- sub-account AND a matching group name as the second sub-account are
+-- further analyzed; all other accounts are discarded. Returns a list
+-- of matching accounts, but only with a list of remaining
+-- sub-accounts after the first and second sub-accounts, and the
+-- balances of these accounts. This computation does not fail.
+
+-- * For each basis account, parse out the purchase information. This
+-- consists of a DateTime, which is the time of the purchase; the Qty
+-- of stock purchased; and the Qty of currency paid for the
+-- stock. Returns this information in a record. Fails if the basis
+-- account does not have exactly two commodities in its balance, or if
+-- there is not a credit balance matching the stock commodity, or if
+-- there is not a debit balance matching the currency commodity, or if
+-- the basis account has more than one remaining sub-account; or if
+-- the DateTime cannot be parsed.
+
+-- * For each basis account, compute the basis realization
+-- information. First sort the basis accounts with the earliest
+-- accounts coming first. Then for each account calculate how many
+-- shares to debit and how much currency to credit. Do this in a
+-- stateful transforming function that will transform the purchase
+-- information into a pair with basis realization information and
+-- purchase information. The state contains the number of shares
+-- remaining that need to have their basis realized, and the total
+-- cost of realized shares.
+
+-- To calculate each basis realization, compare the number of shares
+-- purchased with the number still remaining to be realized. If the
+-- number purchased is less than or equal to the number remaining to
+-- be realized, return a basis realization that realizes all the
+-- shares purchased. If the number of shares purchased is more than
+-- the number still remaining to be realized, then realize all the
+-- shares that still need to be realized, and credit the cost
+-- proportionally. If there are no shares remaining to be realized,
+-- return no realization information at all.
+
+-- Returns a list of pairs of basis realizations and purchase
+-- information; purchases that have no basis realizations are
+-- discarded. Also returns the total cost of shares sold. Fails if
+-- there are still shares that have not had their basis realized
+-- (i.e. the number of shares in the Proceeds account is greater than
+-- the number of shares in the selloff group.)
+
+-- * Compute the capital gain or loss. Take the difference between the
+-- selloff currency quantity and the cost of shares sold. If the
+-- selloff currency quantity is greater, there is a capital
+-- gain. Record credits to an Income:Capital Gain account. If the cost
+-- of shares sold is greater, there is a capital loss. Record debits
+-- to an Expenses:Capital Loss account. To calculate the gain or loss
+-- per purchase transaction, use the allocate function in the Qty
+-- module. The target total is the total capital gain or loss, and
+-- each allocation is the number of shares purchased in each
+-- account. Returns a list of quantities (one for each capital gain or
+-- loss, which corresponds to each purchase account) and an indication
+-- of whether there was a capital gain or loss (this need only be
+-- reported once.) Fails if the allocation fails.
+
+-- * Create output transaction. This never fails (if it does, it is a
+-- programmer error; just apply error.)
+
+-- * In IO monad: Print output transaction.
+
+module Main (main) where
+
+import Control.Arrow (first)
+import Control.Applicative ((<$>), (<*>), pure)
+import qualified Control.Monad.Exception.Synchronous as Ex
+import Control.Monad (when)
+import qualified Control.Monad.Trans.State as St
+import Control.Monad.Trans.Class (lift)
+import Data.List (find)
+import Data.Maybe (isJust, mapMaybe, catMaybes, fromMaybe)
+import Data.Text (pack)
+import qualified Data.Text as X
+import qualified Data.Text.IO as TIO
+import qualified Penny.Lincoln.Balance as Bal
+import qualified Penny.Steel.Sums as S
+import qualified Penny.Cabin.Balance.Util as BU
+import Penny.Cabin.Options (ShowZeroBalances(..))
+import qualified Penny.Copper as Cop
+import qualified Penny.Copper.Parsec as CP
+import qualified Penny.Copper.Render as CR
+import qualified Penny.Liberty as Ly
+import qualified Penny.Lincoln as L
+import qualified Data.Map as M
+import qualified System.Console.MultiArg as MA
+import qualified Text.Parsec as Parsec
+import qualified Paths_penny as PPB
+import qualified Penny as P
+
+type Err = Ex.Exceptional Error
+
+data Error
+ = ParseFail MA.Error
+ | NoInputArgs
+ | ProceedsParseFailed Parsec.ParseError
+ | NoSelloffAccount
+ | NotThreeSelloffSubAccounts
+ | BadSelloffBalance
+ | BadPurchaseBalance
+ | BadPurchaseDate Parsec.ParseError
+ | NotThreePurchaseSubAccounts [L.SubAccount]
+ | BasisAllocationFailed
+ | ZeroCostSharesSold
+ | InsufficientSharePurchases
+ | NoPurchaseInformation
+ | SaleDateParseFailed Parsec.ParseError
+ deriving Show
+
+data ProceedsAcct = ProceedsAcct { _unProceedsAcct :: L.Account }
+ deriving Show
+
+newtype InputFilename = InputFilename { _unInputFilename :: String }
+ deriving (Eq, Show)
+
+data ParseResult = ParseResult ProceedsAcct [Cop.LedgerItem]
+
+parseCommandLine :: IO ParseResult
+parseCommandLine = do
+ as <- MA.simpleHelpVersion help (Ly.version PPB.version)
+ [] MA.Intersperse return
+ x:xs <- case as of
+ [] -> fail (show NoInputArgs)
+ r -> return r
+ a <- Ex.switch (fail . show . ProceedsParseFailed) return
+ . Ex.fromEither
+ $ Parsec.parse CP.lvl1Acct "" (pack x)
+ l <- Cop.open xs
+ return $ ParseResult (ProceedsAcct a) l
+
+
+help :: String -> String
+help pn = unlines
+ [ "usage: " ++ pn ++ " PROCEEDS_ACCOUNT FILE..."
+ , "calculate capital gains and losses from commodity sales."
+ , "Options:"
+ , " -h, --help - show this help and exit."
+ , " --version - show version and exit."
+ ]
+
+calcBalances :: [Cop.LedgerItem] -> [(L.Account, L.Balance)]
+calcBalances =
+ BU.flatten
+ . BU.balances (ShowZeroBalances False)
+ . map (\p -> ((), p))
+ . concatMap L.transactionToPostings
+ . mapMaybe (S.caseS4 Just (const Nothing) (const Nothing)
+ (const Nothing))
+
+newtype Group = Group { unGroup :: L.SubAccount }
+ deriving (Show, Eq)
+
+newtype SaleDate = SaleDate { unSaleDate :: L.DateTime }
+ deriving (Show, Eq)
+
+newtype SelloffStock = SelloffStock { unSelloffStock :: L.Amount L.Qty }
+ deriving (Show, Eq)
+
+newtype SelloffCurrency
+ = SelloffCurrency { unSelloffCurrency :: L.Amount L.Qty }
+ deriving (Show, Eq)
+
+data SelloffInfo = SelloffInfo
+ { siGroup :: Group
+ , siSaleDate :: SaleDate
+ , siStock :: SelloffStock
+ , siCurrency :: SelloffCurrency
+ } deriving Show
+
+selloffInfo
+ :: ProceedsAcct -> [(L.Account, L.Balance)] -> Err SelloffInfo
+selloffInfo (ProceedsAcct pa) bals = do
+ bal <- fmap snd
+ . Ex.fromMaybe NoSelloffAccount
+ . find ((== pa) . fst)
+ $ bals
+ (g, d) <- case L.unAccount pa of
+ _ : s2 : s3 : [] -> return (s2, s3)
+ _ -> Ex.throw NotThreeSelloffSubAccounts
+ (sStock, sCurr) <- selloffStockCurr bal
+ date <- fmap SaleDate
+ . Ex.mapException SaleDateParseFailed
+ . Ex.fromEither
+ . Parsec.parse CP.dateTime ""
+ $ (L.text d)
+ return $ SelloffInfo (Group g) date sStock sCurr
+
+selloffStockCurr :: L.Balance -> Err (SelloffStock, SelloffCurrency)
+selloffStockCurr bal = do
+ let m = L.unBalance bal
+ when (M.size m /= 2) $ Ex.throw BadSelloffBalance
+ let toPair (cy, bl) = case bl of
+ Bal.Zero -> Nothing
+ Bal.NonZero col -> Just (cy, col)
+ ps = mapMaybe toPair . M.toList $ m
+ findBal dc = Ex.fromMaybe BadSelloffBalance
+ . find ((== dc) . Bal.colDrCr . snd)
+ $ ps
+ (cyStock, (Bal.Column _ qtyStock)) <- findBal L.Debit
+ (cyCurr, (Bal.Column _ qtyCurr)) <- findBal L.Credit
+ let sellStock = SelloffStock
+ (L.Amount qtyStock cyStock)
+ sellCurr = SelloffCurrency
+ (L.Amount qtyCurr cyCurr)
+ return (sellStock, sellCurr)
+
+
+basis :: L.SubAccount
+basis = L.SubAccount . pack $ "Basis"
+
+findBasisAccounts
+ :: Group
+ -> [(L.Account, L.Balance)]
+ -> [([L.SubAccount], L.Balance)]
+findBasisAccounts (Group g) = mapMaybe f
+ where
+ f ((L.Account a), b) = case a of
+ s0 : s1 : s2 : ss -> if (s0 == basis) && (s1 == g)
+ then Just (s2:ss, b) else Nothing
+ _ -> Nothing
+
+
+data PurchaseDate = PurchaseDate { unPurchaseDate :: L.DateTime }
+ deriving Show
+
+data PurchaseStockQty
+ = PurchaseStockQty { unPurchaseStockQty :: L.Qty }
+ deriving (Eq, Show)
+
+data PurchaseCurrencyQty
+ = PurchaseCurrencyQty { unPurchaseCurrencyQty :: L.Qty }
+ deriving (Eq, Show)
+
+data PurchaseInfo = PurchaseInfo
+ { piDate :: PurchaseDate
+ , piStockQty :: PurchaseStockQty
+ , piCurrencyQty :: PurchaseCurrencyQty
+ } deriving Show
+
+purchaseInfo
+ :: SelloffStock
+ -> SelloffCurrency
+ -> ([L.SubAccount], L.Balance)
+ -> Err PurchaseInfo
+purchaseInfo sStock sCurr (ss, bal) = do
+ dateSub <- case ss of
+ s1:[] -> return s1
+ _ -> Ex.throw $ NotThreePurchaseSubAccounts ss
+ date <- Ex.mapException BadPurchaseDate
+ . Ex.fromEither
+ . Parsec.parse CP.dateTime ""
+ . L.text
+ $ dateSub
+ (stockQty, currQty) <- purchaseQtys sStock sCurr bal
+ return $ PurchaseInfo (PurchaseDate date) stockQty currQty
+
+purchaseQtys
+ :: SelloffStock
+ -> SelloffCurrency
+ -> L.Balance
+ -> Err (PurchaseStockQty, PurchaseCurrencyQty)
+purchaseQtys (SelloffStock sStock) (SelloffCurrency sCurr) bal = do
+ let m = L.unBalance bal
+ when (M.size m /= 2) $ Ex.throw BadPurchaseBalance
+ let toPair (cy, bl) = case bl of
+ Bal.Zero -> Nothing
+ Bal.NonZero col -> Just (cy, col)
+ ps = mapMaybe toPair . M.toList $ m
+ findBal dc = Ex.fromMaybe BadPurchaseBalance
+ . find ((== dc) . Bal.colDrCr . snd)
+ $ ps
+ (cyStock, (Bal.Column _ qtyStock)) <- findBal L.Credit
+ (cyCurr, (Bal.Column _ qtyCurr)) <- findBal L.Debit
+ when (cyStock /= L.commodity sStock) $ Ex.throw BadPurchaseBalance
+ when (cyCurr /= L.commodity sCurr) $ Ex.throw BadPurchaseBalance
+ return (PurchaseStockQty qtyStock, PurchaseCurrencyQty qtyCurr)
+
+
+newtype RealizedStockQty
+ = RealizedStockQty { unRealizedStockQty :: L.Qty }
+ deriving (Eq, Show)
+
+newtype RealizedCurrencyQty
+ = RealizedCurrencyQty { unRealizedCurrencyQty :: L.Qty }
+ deriving (Eq, Show)
+
+newtype CostSharesSold
+ = CostSharesSold { unCostSharesSold :: L.Qty }
+ deriving (Eq, Show)
+
+newtype StillToRealize
+ = StillToRealize { _unStillToRealize :: L.Qty }
+ deriving (Eq, Show)
+
+data BasisRealiztn = BasisRealiztn
+ { brStockQty :: RealizedStockQty
+ , brCurrencyQty :: RealizedCurrencyQty
+ } deriving Show
+
+-- | Realize an individual purchase account's basis. Fails if the
+-- basis cannot be allocated.
+stRealizeBasis
+ :: PurchaseInfo
+ -> Ex.ExceptionalT Error
+ (St.State (Maybe CostSharesSold, Maybe StillToRealize))
+ (Maybe (PurchaseInfo, BasisRealiztn))
+stRealizeBasis p = do
+ mayTr <- lift $ St.gets snd
+ case mayTr of
+ Nothing -> return Nothing
+ Just (StillToRealize tr) -> do
+ let sq = unPurchaseStockQty . piStockQty $ p
+ pcq = unPurchaseCurrencyQty . piCurrencyQty $ p
+ mayCss <- lift $ St.gets fst
+ case L.difference tr sq of
+
+ L.LeftBiggerBy tr' -> do
+ let br = BasisRealiztn (RealizedStockQty sq)
+ (RealizedCurrencyQty pcq)
+ css' = case mayCss of
+ Nothing -> CostSharesSold pcq
+ Just (CostSharesSold css) ->
+ CostSharesSold (L.add pcq css)
+ lift $ St.put (Just css', Just (StillToRealize tr'))
+ return (Just (p, br))
+
+ L.RightBiggerBy unsoldStockQty -> do
+ let alloced = L.allocate pcq (sq, [unsoldStockQty])
+ basisSold = case alloced of
+ (x, (_ : [])) -> x
+ _ -> error "stRealizeBasis: error"
+ let css' = case mayCss of
+ Nothing -> CostSharesSold basisSold
+ Just (CostSharesSold css) ->
+ CostSharesSold (L.add basisSold css)
+ br = BasisRealiztn (RealizedStockQty tr)
+ (RealizedCurrencyQty basisSold)
+ lift $ St.put (Just css', Nothing)
+ return (Just (p, br))
+
+ L.Equal -> do
+ let br = BasisRealiztn (RealizedStockQty sq)
+ (RealizedCurrencyQty pcq)
+ css' = case mayCss of
+ Nothing -> CostSharesSold pcq
+ Just (CostSharesSold css) ->
+ CostSharesSold (L.add css pcq)
+ lift $ St.put (Just css', Nothing)
+ return (Just (p, br))
+
+realizeBases
+ :: SelloffStock
+ -> [PurchaseInfo]
+ -> Err ([(PurchaseInfo, BasisRealiztn)], CostSharesSold)
+realizeBases sellStck ps = do
+ let stReal = Just . StillToRealize . L.qty
+ . unSelloffStock $ sellStck
+ (exRs, (mayCss, mayTr)) = St.runState
+ (Ex.runExceptionalT (mapM stRealizeBasis ps))
+ (Nothing, stReal)
+ rs <- exRs
+ when (isJust mayTr) $ Ex.throw InsufficientSharePurchases
+ css <- Ex.fromMaybe ZeroCostSharesSold mayCss
+ return (catMaybes rs, css)
+
+newtype CapitalChange = CapitalChange { unCapitalChange :: L.Qty }
+ deriving Show
+
+data WithCapitalChanges
+ = WithCapitalChanges [(PurchaseInfo, BasisRealiztn, CapitalChange)]
+ GainOrLoss
+ | NoChange [(PurchaseInfo, BasisRealiztn)]
+ deriving Show
+
+data GainOrLoss = Gain | Loss deriving (Eq, Show)
+
+capitalChange
+ :: CostSharesSold
+ -> SelloffCurrency
+ -> [(PurchaseInfo, BasisRealiztn)]
+ -> Err WithCapitalChanges
+capitalChange css sc ls =
+ let sellCurrQty = L.qty . unSelloffCurrency $ sc
+ costQty = unCostSharesSold css
+ mayGainLoss =
+ case L.difference sellCurrQty costQty of
+ L.LeftBiggerBy q -> Just (q, Gain)
+ L.RightBiggerBy q -> Just (q, Loss)
+ L.Equal -> Nothing
+ in case mayGainLoss of
+ Nothing -> return . NoChange $ ls
+ Just (qt, gl) -> do
+ nePurchs <- Ex.fromMaybe NoPurchaseInformation
+ . uncons $ ls
+ let qtys = mapNE (unPurchaseCurrencyQty . piCurrencyQty . fst)
+ nePurchs
+ alloced = L.allocate qt qtys
+ let mkCapChange (p, br) q = (p, br, CapitalChange q)
+ r = flattenNE $ zipNE mkCapChange nePurchs alloced
+ return $ WithCapitalChanges r gl
+
+mapNE :: (a -> b) -> (a, [a]) -> (b, [b])
+mapNE f (a, as) = (f a, map f as)
+
+flattenNE :: (a, [a]) -> [a]
+flattenNE (a, as) = a:as
+
+uncons :: [a] -> Maybe (a, [a])
+uncons as = case as of
+ [] -> Nothing
+ x:xs -> Just (x, xs)
+
+zipNE :: (a -> b -> c) -> (a, [a]) -> (b, [b]) -> (c, [c])
+zipNE f (a, as) (b, bs) = (f a b, zipWith f as bs)
+
+memo :: SaleDate -> L.Memo
+memo (SaleDate sd) =
+ let dTxt = CR.dateTime sd
+ txt = pack "transaction created by penny-selloff for sale on "
+ `X.append` dTxt
+ in L.Memo [txt]
+
+payee :: L.Payee
+payee = L.Payee . pack $ "Realize gain or loss"
+
+topLine :: SaleDate -> L.TopLineData
+topLine sd =
+ let core = (L.emptyTopLineCore (unSaleDate sd))
+ { L.tPayee = Just payee
+ , L.tMemo = Just . memo $ sd
+ }
+ in L.TopLineData { L.tlCore = core
+ , L.tlFileMeta = Nothing
+ , L.tlGlobal = Nothing }
+
+basisOffsets
+ :: SelloffInfo
+ -> PurchaseDate
+ -> BasisRealiztn
+ -> ((L.Entry L.Qty, L.PostingData), (L.Entry L.Qty, L.PostingData))
+basisOffsets s pd p = (po enDr, po enCr)
+ where
+ ac = L.Account [basis, grp, dt]
+ grp = unGroup . siGroup $ s
+ dt = dateToSubAcct . unPurchaseDate $ pd
+ enDr = L.Entry L.Debit
+ (L.Amount (unRealizedStockQty . brStockQty $ p)
+ (L.commodity . unSelloffStock . siStock $ s))
+ enCr = L.Entry L.Credit
+ (L.Amount (unRealizedCurrencyQty . brCurrencyQty $ p)
+ (L.commodity . unSelloffCurrency . siCurrency $ s))
+ po en = (en, emptyPostingData ac)
+
+emptyPostingData :: L.Account -> L.PostingData
+emptyPostingData a =
+ let core = (L.emptyPostingCore a)
+ { L.pSide = Just L.CommodityOnLeft
+ , L.pSpaceBetween = Just L.SpaceBetween
+ }
+ in L.PostingData { L.pdCore = core
+ , L.pdFileMeta = Nothing
+ , L.pdGlobal = Nothing
+ }
+
+dateToSubAcct :: L.DateTime -> L.SubAccount
+dateToSubAcct = L.SubAccount . CR.dateTime
+
+income :: L.SubAccount
+income = L.SubAccount . pack $ "Income"
+
+capGain :: L.SubAccount
+capGain = L.SubAccount . pack $ "Capital Gain"
+
+expense :: L.SubAccount
+expense = L.SubAccount . pack $ "Expenses"
+
+capLoss :: L.SubAccount
+capLoss = L.SubAccount . pack $ "Capital Loss"
+
+capChangeAcct
+ :: GainOrLoss
+ -> SelloffInfo
+ -> PurchaseInfo
+ -> L.Account
+capChangeAcct gl si p = L.Account $ case gl of
+ Gain -> [income, capGain, grp, sd, pd]
+ Loss -> [expense, capLoss, grp, sd, pd]
+ where
+ grp = unGroup . siGroup $ si
+ sd = dateToSubAcct . unSaleDate . siSaleDate $ si
+ pd = dateToSubAcct . unPurchaseDate . piDate $ p
+
+capChangeEntry
+ :: GainOrLoss
+ -> SelloffCurrency
+ -> CapitalChange
+ -> L.Entry L.Qty
+capChangeEntry gl sc cc = L.Entry dc (L.Amount qt cy)
+ where
+ dc = case gl of
+ Gain -> L.Credit
+ Loss -> L.Debit
+ cy = L.commodity . unSelloffCurrency $ sc
+ qt = unCapitalChange cc
+
+capChangePstg
+ :: SelloffInfo
+ -> GainOrLoss
+ -> CapitalChange
+ -> PurchaseInfo
+ -> (L.Entry L.Qty, L.PostingData)
+capChangePstg si gl cc p = (en, emptyPostingData ac)
+ where
+ ac = capChangeAcct gl si p
+ en = capChangeEntry gl (siCurrency si) cc
+
+proceeds :: L.SubAccount
+proceeds = L.SubAccount . pack $ "Proceeds"
+
+proceedsPstgs
+ :: SelloffInfo
+ -> ((L.Entry L.Qty, L.PostingData), (L.Entry L.Qty, L.PostingData))
+proceedsPstgs si = (po dr, po cr)
+ where
+ po en = (en, emptyPostingData ac)
+ ac = L.Account [proceeds, gr, dt]
+ gr = unGroup . siGroup $ si
+ dt = dateToSubAcct . unSaleDate . siSaleDate $ si
+ dr = L.Entry L.Debit (unSelloffCurrency . siCurrency $ si)
+ cr = L.Entry L.Credit (unSelloffStock . siStock $ si)
+
+
+mkTxn
+ :: SelloffInfo
+ -> WithCapitalChanges
+ -> L.Transaction
+mkTxn si wcc = fromMaybe err exTxn
+ where
+ err = error "mkTxn: making transaction failed"
+ exTxn = (\topl es -> L.Transaction (topl, es))
+ <$> pure tl <*> L.ents entInputs
+ tl = topLine . siSaleDate $ si
+ (p1, p2) = proceedsPstgs si
+ ps = case wcc of
+ NoChange infoRlzns -> concatMap f infoRlzns
+ where
+ f (p, br) =
+ let (b1, b2) = basisOffsets si (piDate p) br
+ in [b1, b2]
+ WithCapitalChanges trips gl -> concatMap f trips
+ where
+ f (p, br, cc) = [b1, b2, c]
+ where
+ (b1, b2) = basisOffsets si (piDate p) br
+ c = capChangePstg si gl cc p
+ entInputs = map (first (Just . Right)) (p1:p2:ps)
+
+makeOutput
+ :: ProceedsAcct
+ -> [Cop.LedgerItem]
+ -> Err X.Text
+makeOutput pa ldgr = do
+ let bals = calcBalances ldgr
+ formatter = P.getQtyFormat defaultRadGroup ldgr
+ si <- selloffInfo pa bals
+ let basisAccts = findBasisAccounts (siGroup si) bals
+ purchInfos <- mapM (purchaseInfo (siStock si) (siCurrency si))
+ basisAccts
+ (purchBases, css) <- realizeBases (siStock si) purchInfos
+ wcc <- capitalChange css (siCurrency si) purchBases
+ return
+ . (`X.snoc` '\n')
+ . fromMaybe (error "makeOutput: transaction did not render")
+ . (CR.transaction (Just formatter))
+ . (\t -> let (tl, es) = L.unTransaction t
+ in (L.tlCore tl, fmap L.pdCore es))
+ . mkTxn si
+ $ wcc
+
+
+main :: IO ()
+main = parseCommandLine >>= handleParseResult
+
+
+handleParseResult :: ParseResult -> IO ()
+handleParseResult (ParseResult pa ldgr) =
+ Ex.switch (error . show) TIO.putStr . makeOutput pa $ ldgr
+
+defaultRadGroup :: S.S3 L.Radix L.PeriodGrp L.CommaGrp
+defaultRadGroup = S.S3a L.Period
diff --git a/doc/dependencies.dot b/doc/dependencies.dot
new file mode 100644
index 0000000..38af185
--- /dev/null
+++ b/doc/dependencies.dot
@@ -0,0 +1,26 @@
+/* This file shows the dependencies between the different main modules
+of Penny.
+
+To render, run
+dot -Tps dependencies.dot -o dependencies.ps
+*/
+digraph G {
+ Brenner -> Lincoln;
+ Brenner -> Copper;
+ Cabin -> Lincoln;
+ Cabin -> Liberty;
+ Cabin -> Shield;
+ Copper -> Lincoln;
+ Liberty -> Lincoln;
+ Liberty -> Copper;
+ Shield -> Lincoln;
+ Zinc -> Cabin;
+ Zinc -> Copper;
+ Zinc -> Liberty;
+ Zinc -> Lincoln;
+ Zinc -> Shield;
+ Wheat -> Steel;
+ Wheat -> Lincoln;
+ Wheat -> Copper;
+}
+
diff --git a/doc/examples/more-file-format-details.pny b/doc/examples/more-file-format-details.pny
new file mode 100644
index 0000000..9fec7a8
--- /dev/null
+++ b/doc/examples/more-file-format-details.pny
@@ -0,0 +1,167 @@
+# This file contains more details on the Penny file format. Read it if
+# you are interested, or if you are getting error messages you don't
+# understand when you use penny on your file.
+
+########################################
+## - DIGIT GROUPING
+
+# People in different countries use different characters for the radix
+# point (decimal point) and to separate digits into groups. You can
+# choose how you wish to represent quantities in your ledger file.
+# Penny will remember the way you format each individual quantity and
+# the same formatting will be displayed in your reports.
+
+# If you want to use the period as a radix, you can use a comma or a
+# space as a grouping character. If you use a space as a grouping
+# character, you have to surround your quantity with curly braces.
+# Here's an example:
+
+2012-12-16 The Period Radixland
+ Expenses:Periods < $1,284.40
+ Expenses:Periods < $ {2 200.99}
+ Liabilities:Amex
+
+# To use commas as your radix point, you have to surround your
+# quantities with square braces. Then you can use a period or a space
+# as a grouping character. For example:
+
+2012-12-16 The Comma Radixland
+ Expenses:Commas < $ [1.284,40]
+ Expenses:Periods < $ [2 200,99]
+ Liabilities:Amex
+
+# You can also group digits using the Unicode thin space
+# character. This is Unicode code point 2009. Most editors will render
+# it the same way they render a space, but it's not the same
+# character. Different editors will have different ways to enter this
+# character; in Emacs, press C-x 8 <ret> 2009. In Vim, in insert mode
+# press Ctrl-V, then u2009.
+
+# If you use a thin space as a grouping character and you use a period
+# as a radix point, you don't have to surround your quantity with
+# curly braces (though you can if you want.) However, if you use a
+# thin space to group and a comma as a radix, you still have to
+# surround your quantity with square braces. For example:
+
+2012-12-16 The Thin Space
+ {Expenses:Thin Spaces} < $1 000.00
+ {Expenses:Thin Spaces} < $[1 000,00]
+ Liabilities:Amex
+
+# When you use reports such as the postings report, all values that
+# you entered in your ledger will be displayed as you entered them.
+# However, some values such as balances have to be calculated, so
+# Penny has to decide how to format these quantities. Generally Penny
+# will examine all the quantities you have entered in your ledger for
+# a partcular commodity and will format calcualted quantities in the
+# same way that you have most often formatted the quantities for that
+# commodity. So, if you are consistent in how you write quantities in
+# your ledger file, Penny will use the same formatting for calculated
+# quantities.
+
+########################################
+## - USE UNICODE
+
+# Use a Unicode file format when you save your data. Penny works with
+# UTF-8, which is the de-facto standard Unicode encoding on Unix
+# systems. If you do not want to bother with Unicode, it's best to use
+# just the ASCII subset of Unicode. Using a non-Unicode encoding might
+# work, but I have not tested that. Also, if you want to put digit
+# grouping characters in your penny file, Unicode is your only option,
+# as the Unicode thin space (U+2009) is the only digit grouping
+# character you can use.
+
+# If you have no idea what all this encoding stuff is about, the first
+# thing to remember is that there is no such thing as plain text. Read
+# this:
+
+# http://www.joelonsoftware.com/articles/Unicode.html
+
+# Since you can use Unicode, feel free to use whatever currency
+# symbols you want:
+
+2012-12-20 Euroworks
+ Income:Salary > 2100 €
+ Assets:Bank
+
+########################################
+## - DATES
+
+# Dates are written in the format YYYY-MM-DD. If the month or the day
+# has only one digit, you must use leading zeroes. In addition, dates
+# can include a time. Times are written in 24-hour format, either as
+# HH:MM or as HH:MM:SS; again, if any component has only one digit,
+# you must use a leading zero.
+
+# You can use either a dash or a slash to separate YYYY and the MM and
+# the DD.
+
+# All dates and times are considered to be UTC. If you provide a time,
+# you may optionall specify the time zone offset by using a leading
+# plus or a leading minus.
+
+# Here are some sample postings with various dates and times.
+
+2012-12-17 02:23 Transfer from savings
+ Assets:Savings > $200.00
+ Assets:Checking < $200.00
+
+2012-12-17 12:23:35 Transfer from savings
+ Assets:Savings > $200.00
+ Assets:Checking < $200.00
+
+# Eastern time
+2012-12-17 14:56:00 -0500 Transfer from savings
+ Assets:Savings > $200.00
+ Assets:Checking < $200.00
+
+########################################
+## - QUOTING
+
+# Usually you can write information in your ledger file without using
+# characters to indicate which field is which. However, sometimes if
+# you want to use slightly more unusual characters, you have to
+# surround that field with characters. The canonical guide to what you
+# must do is in the bin/doc/ledger-grammar.org file. Here are the highlights:
+
+# Accounts can be unquoted if the very first character of the account
+# is a letter (capital or lower-case, A-Z or a-z) or any character
+# above Unicode code point 127 (e.g. ñ, or é, or í, or...). In
+# addition every other character may be nearly any character except a
+# space or an asterisk. Otherwise, you must surround your account with
+# curly braces. Example:
+
+2012-12-18 CVS
+ {Expenses:Personal Care} < $52.35
+ 'Earplugs
+ Liabilities:Amex
+
+# You can assign payees to individual postings as well as to the
+# entire transaction. Payees assigned to individual postings must be
+# surrounded with tildes. You do not usually have to quote payees that
+# are assigned to the whole transaction; however, you do have to quote
+# them if the first character is not a letter. Examples:
+
+2012-12-18 ~7-Eleven~
+ Expenses:Food < $12.99
+ Liabilities:Amex
+
+2012-12-19 Spacely Sprockets
+ Income:Salary > $2000.00
+ ~State of Maryland~ Expenses:Taxes:State < $200.00
+ ~Healthco~ Expenses:Insurance:Health < $75.00
+ Assets:Checking
+
+# Whether or not you have to quote commodities is complicated.
+# Currently this is documented only in the source code (sorry). The
+# full rule set depends on whether the commodity appears on the left
+# side or the right side of the quantity. (Whether there is a space
+# between the commodity and the quantity is not relevant.)
+
+# However, here is a simple rule that is always true. If your
+# commodity name consists ONLY of letters, the dollar sign, and
+# non-ASCII characters, you never need to quote it. Since most stock
+# ticker symbols are only letters, and because this means that you
+# never have to quote lone commodity symbols like $, €, ¥, etc, you
+# should not usually have to quote commodities.
+
diff --git a/doc/examples/starter.pny b/doc/examples/starter.pny
new file mode 100644
index 0000000..805f242
--- /dev/null
+++ b/doc/examples/starter.pny
@@ -0,0 +1,258 @@
+# This file contains some sample Penny data. It is used as a basis for
+# the examples in the penny-getting-started manual page.
+
+# This file, like all of Penny, assumes you have basic knowledge of
+# double-entry accounting. See penny-basics(1).
+
+# As you can see, comments begin with the # symbol. You can only have
+# single-line comments; there are no multi-line comments (e.g. like
+# <!-- --> in XML or /* */ in C.) Also, comments must be the only item
+# on a line (you cannot, for example, have part of a posting on one
+# line and then a comment at the end of the same line.)
+
+# We will distinguish between *transactions* and *postings*. A posting
+# must have, at a minimum, an account, an indication of whether it is
+# a debit or a credit, a commodity, and a quantity. A transaction must
+# have at least two postings. All the postings in a transaction must
+# balance--that is, their debits and credits must add up to the same
+# number.
+
+# Some first examples:
+
+2012-12-01 Opening balances
+ Equity > $1554.60
+ Assets:Checking < $1554.60
+
+2012-12-01 Spacely Sprockets
+ Income:Salary > $3000.00
+ Assets:Checking < $3000.00
+
+# As shown above, debits are indicated with < (a less-than sign, which
+# looks like a left-pointing arrow) and credits with a > (which looks
+# like a right-pointing arrow.) So, in the "Spacely Sprockets"
+# transaction, you have debited your Assets:Checking account by $3000,
+# and you have credited your Salary account by $3000.
+
+# If you try to have a transaction which is NOT balanced--that is, the
+# sum of the debits is not equal to the sum of the credits--then Penny
+# will complain and quit. The following text is not a valid
+# transaction so it is commented out:
+
+# 2012-12-01 Unbalanced
+# Income:Salary > $3000.00
+# Assets:Checking > $3000.00
+
+# There, you have two credits, but no debit.
+
+# Penny has no concept of negative numbers. All numbers are
+# positive. Furthermore, quantities cannot be zero--they must be
+# greather than zero, even if infinitesimally so.
+
+# Some more transactions to get us started:
+2012-12-01 Landlord
+ Expenses:Rent < $700.00
+ Assets:Checking > $700.00
+
+2012-12-02 Whole Foods
+ Expenses:Food < $43.10
+ Assets:Checking > $43.10
+
+2012-12-02 Amazon.com
+ Expenses:Books < $23.99
+ Liabilities:Amex > $23.99
+
+# You can choose not to indicate the debit/credit, commodity, and
+# quantity for one of the postings. Penny will use the debit or
+# credit, quantity, and commodity from the one that you fill in to
+# "infer" what is is for the other posting.
+
+2012-12-02 CVS
+ Expenses:Drugs < $12.14
+ Assets:Checking
+
+# Here, Penny infers that the Assets:Checking account is credited
+# $12.14.
+
+# The different parts of your Penny file--accounts, dates, and so
+# on--are separated with spaces. If you have data that includes
+# spaces--for instance, you have a space in an account name--then you
+# have to surround it with special characters. This is called
+# "quoting". This is also true if you want to include other special
+# characters in a particular part of your file. For example, to quote
+# an account that has spaces, use curly braces:
+
+2012-12-03 CVS
+ {Expenses:Personal Care} < $82.21
+ Liabilities:Amex
+
+# When you are writing a payee name in the first line of a transaction
+# (next to the date), it's okay to have spaces.
+
+# You can have more than two postings in a transaction. Your debits
+# and credits still have to be equal:
+2012-12-03 Safeway
+ Expenses:Food < $8.94
+ {Expenses:Personal Care} < $20.00
+ Liabilities:Amex > $28.94
+
+# If you have more than two postings, you can still leave one of them
+# without a debit or credit, commodity, and quantity, and Penny will
+# infer what it is.
+2012-12-04 Home Depot
+ Expenses:Hardware < $50.00
+ Expenses:Garden < $9.97
+ Liabilities:Amex
+
+# Each account is broken into "sub-accounts", which are separated by
+# colons. In all the examples we've seen so far, there are two
+# sub-accounts, but you can have as many or as few (down to one)
+# sub-accounts as you like.
+2012-12-05 Whole Foods
+ Expenses:Entertaining:Food < $67.75
+ Assets:Checking
+
+# Postings can have memos. The memo begins with an apostrophe.
+2012-12-06 Eli Zabar
+ Expenses:Food < $23.04
+ 'Some expensive bread.
+ 'Next time try the one with the raisins.
+ Liabilities:Amex
+
+# In addition, transactions can have memos. Each line of these begins
+# with a semicolon. They must appear immediately before a
+# transaction. They are different from comments because a transaction
+# memo is associated with its transaction, while a comment is
+# associated with nothing.
+
+; Tried the new Potbelly
+2012-12-06 Potbelly
+ Expenses:Food < $9.83
+ Liabilities:Amex
+
+# Whitespace separates the different elements of a transaction and a
+# posting. However Penny does not impose particular indentation on
+# you. The indentation you see above is just a convention that I think
+# looks readable, but you can do it a different way. Penny also does
+# not take sides in the tabs vs spaces holy war.
+
+2012-12-06 Duane Reade
+Expenses:Magazines < $2.98
+Liabilities:Amex
+
+# You do however have to keep each posting on a separate line, and you
+# have to keep all the lines of a transaction together without any
+# blank lines in between.
+
+# You can also choose how to write your commodities--that is, before
+# or after the quantity, and with or without a space between the
+# commodity and the quantity. Currently Penny remembers how you write
+# your commodities, though what it remembers has effects in only a few
+# places. In particular, it does not affect how your reports are formatted.
+
+# Ok, so this following example does not really make sense with
+# dollars, but it gives you the idea.
+
+2012-12-06 Flo
+ Expenses:Insurance:Car < 230.00 $
+ Assets:Checking
+
+# Transactions and postings can have a "flag". I use only
+# single-character flags; however, you can make your flags as long as
+# you like. A flag is enclosed in square brackets. You might use these
+# to indicate when a transaction has cleared your bank, or to remember
+# what kind of a transaction it is.
+
+# This flag applies to the entire transaction.
+2012-12-06 [ATM] Cash
+ Assets:Checking > $100.00
+ Expenses:Cash
+
+# This flag applies just to the posting it is next to.
+2012-12-10 Cash
+ Expenses:Cash < $100.00
+ [ATM] Assets:Checking
+
+# Similarly, transactions and postings can have a "number". You might
+# use this for check numbers. This number applies to the whole
+# transaction...
+
+2012-12-11 (804) Comcast
+ Expenses:Cable < $123.99
+ Assets:Checking
+
+# ... and this one just to the posting.
+
+2012-12-12 Washington Gas
+ Expenses:Utilities:Gas < $23.14
+ (805) Assets:Checking
+
+# The payee on the first line of the posting is optional. The only
+# thing required on the first line is the date. You can also put a
+# payee on the individual postings, but they must be surrounded with
+# tildes.
+
+2012-12-12
+ ~Zork enterprises~ (203) [R] Expenses:Gifts < $16.99
+ [R] ~Barristers Inc.~ (204) Expenses:Gifts < $42.99
+ Assets:Checking
+
+# As the above example shows, you can have a payee, number, and flag
+# on a single posting, or any combination of those. They can appear in
+# any order. The account name always appears after these.
+
+# A posting can have tags. This gives you another way (beyond
+# accounts) to classify postings. For example, let's say you take a
+# vacation. You spend money and put the expenses in different
+# accounts, but you want to track the vacation expenses together. You
+# precede each tag with an asterisk (you can have more than one tag on
+# a posting) and the tags go after the account name. A tag can have
+# nearly any character except for '<', '>', '*', or a space.
+
+2012-12-13 Amtrak
+ {Expenses:Train fare} *vacation2012 < $700.00
+ Liabilities:Amex
+
+2012-12-14 Fitzpatrick Grand Central Hotel
+ Expenses:Hotel *vacation2012 < $400.00
+ Liabilities:Amex
+
+# You can use either dashes or slashes as the date separator. You can
+# even mix them up :)
+
+2012/12-15 Aquagrill
+ Expenses:Food *vacation2012 < $87.00
+ Liabilities:Amex
+
+# That's everything you need to get started recording your data with
+# Penny. If you want to track multiple commodities (for instance
+# stocks, or the price of your real estate) look at the stocks.pny
+# file, which will help you get started there.
+
+# Here are some more transactions that will provide useful fodder for
+# the manual pages:
+
+2012-12-16 Import savings
+ {Equity:Opening Balances} > $32985.23
+ Assets:Savings
+
+2013-01-02 Conoco
+ Expenses:Gas < $54.22
+ Assets:Checking
+
+2012-01-04 Express
+ Expenses:Clothes < $103.00
+ Liabilities:Amex
+
+2012-01-05 Amazon.com
+ Expenses:Food < $23.60
+ Expenses:Books < $16.00
+ Liabilities:Amex
+
+2012-01-06 Landlord
+ Expenses:Rent < $700.00
+ Assets:Checking
+
+2012-01-06 Spacely Sprockets
+ Income:Salary > $3000.00
+ Assets:Checking
+
diff --git a/doc/examples/stocks-realized.pny b/doc/examples/stocks-realized.pny
new file mode 100644
index 0000000..0936d4c
--- /dev/null
+++ b/doc/examples/stocks-realized.pny
@@ -0,0 +1,14 @@
+; transaction created by penny-selloff for sale on 2012-12-31
+2012-12-31 Realize gain or loss
+ {Proceeds:LUV:2012-12-31} < $ 4800.00
+ {Proceeds:LUV:2012-12-31} > LUV 300
+ {Basis:LUV:2012-10-19} < LUV 100
+ {Basis:LUV:2012-10-19} > $ 1000.00
+ {Income:Capital Gain:LUV:2012-12-31:2012-10-19} > $ 333.33
+ {Basis:LUV:2012-11-19} < LUV 100
+ {Basis:LUV:2012-11-19} > $ 1200.00
+ {Income:Capital Gain:LUV:2012-12-31:2012-11-19} > $ 400.00
+ {Basis:LUV:2012-12-19} < LUV 100
+ {Basis:LUV:2012-12-19} > $ 1400.00
+ {Income:Capital Gain:LUV:2012-12-31:2012-12-19} > $ 466.67
+
diff --git a/doc/examples/stocks.pny b/doc/examples/stocks.pny
new file mode 100644
index 0000000..61b0d4b
--- /dev/null
+++ b/doc/examples/stocks.pny
@@ -0,0 +1,246 @@
+# This file documents some recommended practices for dealing
+# with multi-commodity transactions.
+
+# You might want to examine this tutorial that discusses
+# multiple-commodity double-entry accounting generally; it is quite
+# useful.
+#
+# http://www.mscs.dal.ca/~selinger/accounting/tutorial.html
+
+# All the examples in the starter.pny file use dollars as the
+# commodity. However, Penny is flexible: you can track any commodity
+# you want. The simple rule is that all transactions must be
+# balanced--that is, the sum of the debits must be equal to the sum of
+# the credits. Each posting can have only one commodity. A debit sum
+# of one commodity must be offset by a credit sum of the same
+# commodity. So, let's say you buy 100 shares of F for $1 each. The
+# following transaction is INVALID so it is commented out:
+
+# 2012/12/19 Buy stock
+# Assets:Checking > $100.00
+# Assets:Brokerage < 100 F
+
+# That transaction is not balanced. The $100 credit needs an
+# offsetting $100 debit, and the debit of 100 F needs an offsetting
+# credit of 100 F. Here's the method I recommend:
+
+2012-10-19 Purchase stock
+ Assets:Brokerage < 100 F
+ Assets:Checking > $1000.00
+ Basis:F:2012-10-19 > 100 F
+ Basis:F:2012-10-19 < $1000.00
+
+# Offsetting your debit and credit against a single Basis account will
+# allow you to get more useful information out of your ledger file, as
+# we will see later. By naming the Basis account as shown here (with
+# the second sub-account being the commodity symbol, and the third
+# sub-account being the date on which the commodity was purchased) the
+# penny-selloff program will be able to help you out later when you
+# sell the commodity.
+
+# You will also want to enter a price into your file. The convert
+# report will use this information. A price tells the convert report
+# how to convert one commodity to another. Prices have no effect on
+# any other Penny report. For instance this price expresses the price
+# of the prevoius transaction:
+
+@ 2012-10-19 F $10.00
+
+# This means that one unit of F is equivalent to $10.00. Prices only
+# work one way; that is, the price above does NOT tell Penny that
+# $10.00 is equivalent to one unit of F. If you wanted to express
+# that, include another price. It is only possible to express that ONE
+# unit of some commodity is equal to some number of units of another
+# commodity. For instance, this price would be invalid:
+#
+# @ 2012-10-19 100F $1000.00
+
+
+# Any transaction that has two commodities will have at least four
+# postings. This is because all transasctions in Penny must always be
+# balanced, and every debit balance must be offset with a credit
+# balance of the exact same commodity.
+
+# A month later I sell my stock. Let's say it has done very well.
+
+2012-11-19 Sell stock
+ Assets:Brokerage > 100 F
+ Assets:Checking < $1400.00
+ Basis:F:2012-10-19 < 100 F
+ Basis:F:2012-10-19 > $1400.00
+
+# And a corresponding price:
+
+@ 2012-11-19 F $14.00
+
+# At this point, Basis:F:2012-10-19 has a credit balance of
+# $400.00. This is your capital gain from the sale. You probably want
+# to close out the Basis:F:2012-10-19 account by transferring its
+# balance to an income account. (You could even do this in the same
+# transaction as the stock sale.)
+
+2012-11-19 Capital Gain
+ Basis:F:2012-10-19 < $400.00
+ {Income:Capital Gain:F:2012-10-19} > $400.00
+
+# That's one way to do it. It's simple enough when you just have
+# one lot of stock. What if you have a bunch of different lots?
+# This can happen with dividend reinvestment especially. Here's
+# an example:
+
+2012-10-19 Purchase stock
+ Assets:Brokerage < 100 LUV
+ Assets:Checking > $1000.00
+ Basis:LUV:2012-10-19 > 100 LUV
+ Basis:LUV:2012-10-19 < $1000.00
+
+2012-11-19 Purchase stock
+ Assets:Brokerage < 100 LUV
+ Assets:Checking > $1200.00
+ Basis:LUV:2012-11-19 > 100 LUV
+ Basis:LUV:2012-11-19 < $1200.00
+
+2012-12-19 Purchase stock
+ Assets:Brokerage < 100 LUV
+ Assets:Checking > $1400.00
+ Basis:LUV:2012-12-19 > 100 LUV
+ Basis:LUV:2012-12-19 < $1400.00
+
+
+# Okay, time to sell. Get rid of all the LUV. To get the capital gain
+# right, it must be distributed amongst all the LUV purchases. You
+# could do this yourself but who wants to? So enter a transaction
+# like this first:
+
+2012-12-31 Sell stock
+ Assets:Brokerage > 300 LUV
+ Assets:Checking < $4800.00
+ Proceeds:LUV:2012-12-31 < 300 LUV
+ Proceeds:LUV:2012-12-31 > $4800.00
+
+# At this point your assets and brokerage accounts look good. If you
+# don't care about capital gains, you can just stop here. But if you
+# want to close out the Basis accounts, you can use the penny-selloff
+# program. It creates transactions for you, which you can append to
+# your Penny file. You pass penny-selloff two arguments: first, the
+# name of the Proceeds account, and second, the filename to draw from.
+
+# penny-selloff 'Proceeds:LUV:2012-12-31' filename
+
+# penny-selloff will use all transactions from all the filenames
+# given. First it will make sure that the given Proceeds account has a
+# balance that consists of a debit amount and a credit amount with
+# differing commodities. penny-selloff takes the debit amount to be
+# the commodity you are selling off, and the credit amount of the
+# balance is the amount you received in the sale.
+
+# penny-selloff then takes the second sub-account from the given
+# account. Here, it is LUV. It then looks for accounts named
+# Basis:SUB-ACCOUNT:***. Here it looks for Basis:LUV:***. *** is a
+# Penny date (and optional time.) All of these accounts that have a
+# balance are totaled up. This total balance must have a credit
+# balance that is greater than or equal to the debit balance of the
+# Proceeds account, and a debit balance whose commodity is the same
+# commodity as the credit balance of the Proceeds account.
+
+# penny-selloff then computes a per-share price of the proceeds and
+# calculates sale postings for each Basis account that has a
+# balance. Shares are sold off on a FIFO (first-in, first-out) basis,
+# so the oldest available shares are sold first. blah blah blah blah
+
+# so for example, with the above transactions, running
+
+# penny-selloff 'Proceeds:LUV:2012-12-31' stocks.pny
+
+# will create a posting that looks like this:
+
+;transaction created by penny-selloff for sale on 2012-12-31
+2012-12-31 Realize gain or loss
+ Proceeds:LUV:2012-12-31 < $ 4800.00
+ Proceeds:LUV:2012-12-31 > LUV 300
+ Basis:LUV:2012-10-19 < LUV 100
+ Basis:LUV:2012-10-19 > $ 1000.00
+ {Income:Capital Gain:LUV:2012-12-31:2012-10-19} > $ 333.33
+ Basis:LUV:2012-11-19 < LUV 100
+ Basis:LUV:2012-11-19 > $ 1200.00
+ {Income:Capital Gain:LUV:2012-12-31:2012-11-19} > $ 400.01
+ Basis:LUV:2012-12-19 < LUV 100
+ Basis:LUV:2012-12-19 > $ 1400.00
+ {Income:Capital Gain:LUV:2012-12-31:2012-12-19} > $ 466.66
+
+# Thus the capital gain shows up in the Capital Gain account, and all
+# the Basis accounts and the Proceeds account have zero balances.
+
+# You could also track commodities other than stocks. Let's say you
+# buy a house.
+
+2012-12-31 Buy a house
+ {Assets:Real Estate} < HouseA 1
+ Liabilities:Mortgage > $ 80 000.00
+ Assets:Savings > $ 20 000.00
+ 'Down payment
+ Basis:House1:2012-12-31 > HouseA 1
+ Basis:House1:2012-12-31 < $ 100 000.00
+
+@ 2012-12-31 HouseA $100 000.00
+
+# And some more stock purchases that we can use as examples in the
+# penny-commodities man page:
+2012-09-17 Buy stock
+ Assets:Brokerage < 100 YHOO
+ Basis:YHOO:2012-09-17 > 100 YHOO
+ Assets:Checking > $1568.00
+ Basis:YHOO:2012-09-17 < $1568.00
+
+@ 2012-09-17 YHOO $15.68
+
+2012-11-16 Buy stock
+ Assets:Brokerage < 100 YHOO
+ Basis:YHOO:2012-11-16 > 100 YHOO
+ Assets:Checking > $1786.00
+ Basis:YHOO:2012-11-16 < $1786.00
+
+@ 2012-11-16 YHOO $17.86
+
+2012-12-18 Buy stock
+ Assets:Brokerage < 100 YHOO
+ Basis:YHOO:2012-12-18 > 100 YHOO
+ Assets:Checking > $1982.00
+ Basis:YHOO:2012-12-18 < $1982.00
+
+@ 2012-12-18 YHOO $19.82
+
+@ 2012-12-20 YHOO $19.69
+
+# And your house is going up in value:
+
+@ 2013-01-01 HouseA $101 000.00
+@ 2013-06-01 HouseA $102 000.00
+
+# And an example involving the purchase and sale of stock:
+
+2012-01-03 Buy stock
+ Assets:Brokerage < 100 UNP
+ Assets:Checking > $10800.00
+ Basis:UNP:2012-01-03 > 100 UNP
+ Basis:UNP:2012-01-03 < $10800.00
+
+2012-12-28 Sell stock
+ Assets:Brokerage > 100 UNP
+ Assets:Checking < $12354.00
+ Basis:UNP:2012-01-03 < 100 UNP
+ Basis:UNP:2012-01-03 > $12354.00
+
+# Here is another example of a sale using a Proceeds account:
+2012-01-03 Buy stock
+ Assets:Brokerage < 100 C
+ Assets:Checking > $3072.00
+ Basis:C:2012-01-03 > 100 C
+ Basis:C:2012-01-03 < $3072.00
+
+2012-12-03 Sell stock
+ Assets:Brokerage > 100 C
+ Assets:Checking < $3901.00
+ Proceeds:C:2012-12-03 < 100 C
+ Proceeds:C:2012-12-03 > $3901.00
+
diff --git a/doc/man/penny-basics.7 b/doc/man/penny-basics.7
new file mode 100644
index 0000000..d5bf90a
--- /dev/null
+++ b/doc/man/penny-basics.7
@@ -0,0 +1,372 @@
+.TH penny-basics 1
+
+.SH NAME
+penny-basics - getting started with Penny
+
+.SH PENNY IS DOUBLE-ENTRY ACCOUNTING
+
+Penny is a double-entry accounting system. Other accounting systems
+use double-entry principles--indeed, they are double-entry accounting
+systems--but they do not use traditional double-entry accounting terms
+such as
+.I debit
+and
+.IR credit .
+Or, they might use these terms, but not as they are used in a
+traditional accounting sense. Unlike other systems, Penny does not try
+to hide the details of double-entry accounting from you. Therefore,
+you will need to have basic knowledge of double-entry accounting to
+use Penny.
+
+Ask yourself this question: what is a debit? If you said "it's what
+happens when my bank charges me money," read "Learning about
+double-entry accounting" below. If you said "left", then you're
+probably ready to use Penny.
+
+.SH LEARNING ABOUT DOUBLE-ENTRY ACCOUNTING
+
+Since there are many great places to learn the basics of double-entry
+accounting, I won't try to write about it here. Instead, here are some
+places to look.
+
+.IP \(bu
+The Wikipedia article on double-entry accounting
+(http://en.wikipedia.org/wiki/Double-entry_bookkeeping_system) is
+good.
+
+.IP \(bu
+Principles of Accounting (http://www.principlesofaccounting.com/) is a
+great free online text.
+
+.IP \(bu
+Or, go to your favorite bookseller and find a used textbook on
+accounting. These can be had for less than ten U.S. dollars, including
+shipping.
+
+.SH THE penny PROGRAM
+
+The
+.B penny
+program is Penny's most basic tool. It gives you reports on what you
+have recorded in your
+.IR ledger ,
+which is simply a text file (or multiple files) containing your
+financial transactions.
+.B penny
+will never modify the data in your ledger; you maintain it yourself by hand (or by using some of the other programs in the
+.B penny
+suite, such as
+.BR penny-fit ,
+which will modify this data for you under some circumsances.)
+
+Examine the
+.I starter.pny
+file, located in the
+.I examples
+directory of the
+.I penny-bin
+package. It shows the basics of how to write a Penny ledger file. This
+man page will use this file for examples. Please follow along by
+typing some of the commands yourself and experiment on your own.
+
+.SH HOW penny WORKS
+First, some terminology. Your ledger file contains
+.IR transactions .
+Each transaction consists of at least two
+.BR postings .
+All the postings in a transaction must
+.IR balance ;
+that is, the sum of the debits for each commodity must equal the sum
+of the credits for that commodity.
+.B penny
+first reads in all your transactions. All the transactions must be balanced; if they are not,
+.B penny
+quits with an error message. Then
+.B penny
+splits the transactions into postings. After that,
+.B penny
+deals only with the postings, and not with the transactions that they were a part of.
+
+.B penny
+then will discard some of the postings and keep others, depending on the
+.I filter specification
+that you give. You can also sort the postings; by default they are left in the order that they were in in the file. Then a
+.I report
+that you specify is shown. The reports have additional options that you may specify.
+
+This is all more clear with some examples, so let's go!
+
+.SH SEEING THE POSTINGS IN AN ACCOUNT
+
+Let's say you want to see the postings in your checking account.
+
+.EX
+penny --account Assets:Checking postings starter.pny
+.EE
+
+does what you would expect. If you want to limit the postings to those
+before or after a certain date, try one of these:
+
+.EX
+penny -a Assets:Checking --and -d '>=' 2012-12-06 postings starter.pny
+.EE
+
+.EX
+penny -a Assets:Checking --and -d '>=' 2012=12-06 --and \\
+ -d '<' 2012-12-11 postings starter.pny
+.EE
+
+As these examples show, you can use
+.I -a
+instead of
+.IR --account ,
+and
+.I -d
+instead of
+.IR --date .
+Also, options such as
+.I -a
+and
+.I -d
+are called
+.IR operands .
+If you use more than one operand, you must join them together using
+.IR operators .
+The operators available to you are
+.IR "--not " , "--and " ", and " "--or" ,
+in that order of precedence. Here is a more complicated example that
+uses the various operators and operands:
+
+.EX
+penny -a Assets:Checking --and --open --payee 'Whole Foods' \\
+ --or --payee Comcast --close --and --date '>=' 2012-12-01 --and \\
+ --date '<' 2012-01-01 pos starter.pny
+.EE
+
+This example also shows that you can abbreviate the name of the
+report; that is, instead of
+.IR postings ,
+you can say
+.IR pos .
+You can use the shortest unambiguous abbreviation, so you could even
+simply say
+.I p
+as there is no other report that starts with a
+.IR p .
+
+On the far right side of each
+.I postings
+report is a running balance, like in a checkbook register. You may have noticed that in the examples above the running total reflects only the postings you saw in the report. Sometimes that is what you want. Other times you might want to see the total running balance, even as it is affected by the postings not shown in the report. To do this, include the filtering options
+.B after
+the word
+.I postings
+rather than before. Filtering options that are included before the word
+.I postings
+affect which postings are part of the report. Only postings that are part of the report affect the running balance. Filtering options
+.B after
+the word
+.I postings
+affect which postings are
+.B shown
+in the report. Postings that are part of the report but are not shown
+still affect the running balance.
+
+Here is an example:
+
+.EX
+penny --sort date -a Assets:Checking pos -d '>' 2012-12-10 \\
+ starter.pny
+.EE
+
+This example introduces a new option,
+.IR --sort .
+You specify the field name on which you want to sort your postings. To
+sort them in ascending order, use all lower case letters when
+specifying the name of the field. To sort in descending order,
+capitalize the first letter. By default,
+.B penny
+does not sort your postings; it leaves them in the same order they
+were in in your ledger file. If you want to see the running balance of
+a report, it's important to make sure the postings are sorted in
+chronologial order, either because you told
+.B penny
+to sort them or because you always keep your postings in chronological
+order in your ledger file (I don't.)
+
+Here we also see that you can use the
+.I -d
+option in place of
+.IR --date .
+
+.SH SEEING THE BALANCE OF AN ACCOUNT
+
+To see the balance of your checking account, you could run
+
+.EX
+penny -a Assets:Checking pos --tail 1 starter.pny
+.EE
+
+and look at the running balance shown. This command included all the
+postings in your checking account in the postings report, but it only
+showed the last posting. (You could have used the UNIX
+.B tail
+program, but that will not always work well because sometimes a single
+posting will take up more than one line on your screen.)
+
+Another way to do it is with
+
+.EX
+penny -a Assets:Checking balance starter.pny
+.EE
+
+which shows the accounts hierarchically. The
+.I balance
+report is your friend if you want to see the balance of many accounts
+at once.
+
+.SH INCOME AND EXPENSES
+
+How does your income compare to your expenses for a certain month?
+Try:
+
+.EX
+penny --open --account-level 0 Income --or --account-level 0 Expenses \\
+ --close --and -d '>=' 2012-12-01 --and -d '<' 2013-01-01 \\
+ balance starter.pny
+.EE
+
+The
+.I --account-level
+operand takes two arguments. The first one is the number of the sub-account you wish to match. For instance, the account
+.I Expenses:Food
+has two sub-accounts: the first,
+.IR Expenses ,
+is numbered 0, and the second,
+.IR Food ,
+is numbered 1. The second argument to
+.I --account-level
+is the pattern you wish to use. All matching accounts will be part of your
+.I balance
+report. The result of this command shows your total expenses and total income, and the difference between the two is shown on the top
+.I Total
+line. (You don't have to use the
+.I --account-level
+operand, but it is more precise in this instance. Even more precise
+would have been to specify
+.I --exact
+at the beginning of the command line. Without
+.IR --exact ,
+a pattern matches if the pattern you specify is found anywhere within
+the target text.)
+
+.SH BALANCING YOUR CHECKBOOK
+
+Or, that fun task also known as "reconciling your account." First you
+want to make sure that the reconciled balance of your checking account
+is the same as what the bank says it was:
+
+.EX
+penny -a Assets:Checking --and --flag R bal starter.pny
+.EE
+
+Compare this total against the opening balance shown on your bank
+statment. If they match, good. If not, figure out why and fix it
+before proceeding. Then, find each posting shown on your bank
+statement in your ledger. Add a
+.I C
+flag to each posting. After you have found all the bank's postings in
+your ledger, run this:
+
+.EX
+penny -a Assets:Checking --and --open --flag R --or --flag C --close \\
+ bal starter.pny
+.EE
+
+The balance shown should match what is on your bank statement. If not,
+make sure you have matched up all the bank's postings with a posting
+in your file, and make sure the bank's amount matches your amount. You
+can easily see which postings you have just marked as cleared with:
+
+.EX
+penny -a Assets:Checking --and --flag C pos stater.pny
+.EE
+
+Once the balances match up, use your text editor or
+.BR penny-reconcile (1)
+to change the
+.I C
+flags to
+.I R
+flags.
+
+.SH WHAT'S YOUR NET WORTH?
+
+Try
+
+.EX
+penny -a Assets --or -a Liabilities balance starter.pny
+
+.SH COLORS
+
+Output from
+.B penny
+is easier to read when it's colorful.
+.B penny
+can use up to 256 colors on your terminal. Just make sure that your
+.I TERM
+environment variable is set to a terminal that supports 256 colors. I use
+.BR xterm (1),
+which supports 256 colors, but by default
+.B xterm
+sets the
+.I TERM
+environment variable to
+.IR xterm ,
+which only supports 8 colors. To make
+.B xterm
+set the
+.I TERM
+environment variable to one that supports 256 colors, I have the following text in my
+.I ~/.Xresources
+file:
+
+.EX
+XTerm*termName: xterm-256color
+.EE
+
+After running
+
+.EX
+xrdb -merge ~/.Xresources
+.EE
+
+and launching a new
+.BR xterm ,
+the new setting should take effect. It's likely your operating system
+is already set up to automatically merge your
+.I ~/.Xresources
+file when you launch an X session.
+
+If you don't like colors, use
+.IR "--scheme plain" .
+By default,
+.B penny
+does not use colors if its standard output is not a terminal, though you can override this with
+.IR --color-to-file=yes .
+This can be useful if you are sending output to a pager such as
+.BR less (1)
+and you want to see colors (with
+.BR less ,
+you will want to use the
+.I -R
+option.)
+
+.SH WHERE TO GO FROM HERE
+
+This is enough to get you started with
+.BR penny .
+If you want to know more, see
+.BR penny (1),
+which is an exhaustive reference. Also, see
+.BR penny-suite (7),
+which lists all Penny programs and documentation.
diff --git a/doc/man/penny-commodities.7 b/doc/man/penny-commodities.7
new file mode 100644
index 0000000..cfcb0aa
--- /dev/null
+++ b/doc/man/penny-commodities.7
@@ -0,0 +1,199 @@
+.TH penny-commodities 7
+
+.SH NAME
+penny-commodities - tracking multiple commodities with Penny
+
+.SH INTRODUCTION
+
+Using
+.B penny
+is easy if you only want to track one commodity--most likely your home
+country's currency. Things get a little more complicated if you want
+to track more than one commodity, such as stocks, bonds, real estate,
+or depreciable assets like vehicles. You probably want to keep track
+of how much the commodity cost and the ultimate capital gain or loss.
+
+This man page will tell you how to make entries in your ledger file
+for commodity purchases, and how you can use
+.B penny
+to gather the information you need. You will also want to examine the
+.I stocks.pny
+file, which is in the
+.I examples
+directory of the
+.I penny-bin
+tarball. It contains many examples.
+
+.SH ALL TRANSACTIONS MUST BE BALANCED
+
+This means that the sum of all debits of a given commodity must equal
+the sum of all credits of the same commodity. So, what if you want to
+buy a commodity, like a stock? You could not record a transaction like
+the following one, because it is not balanced:
+
+.EX
+# 2012-01-01 Purchase stock
+# Assets:Brokerage < 100 LUV
+# Assets:Checking > $1000.00
+.EE
+
+The transaction above is not balanced. Penny will never allow you to
+create unbalanced transactions. Here is how I recommend solving this
+problem:
+
+.EX
+2012-01-01 Purchase stock
+ Assets:Brokerage < 100 LUV
+ Assets:Checking > $1000.00
+ Basis:LUV:2012-01-01 > 100 LUV
+ Basis:LUV:2012-01-01 < $1000.00
+.EE
+
+This transaction is balanced. You will also find it helpful to record
+a price:
+
+.EX
+@ 2012-01-01 LUV $10.00
+.EE
+
+This tells
+.B penny
+that on that date, one share of LUV was worth $10.00.
+.B penny
+will only know this if you tell it so; it will not infer this
+information from the transactions you enter. Currently prices are only
+used by the
+.I convert
+report, as we will see shortly.
+
+.SH GAINS AND LOSSES BEFORE SALE
+
+You have bought shares of YHOO at various times and you have entered
+prices for them in your ledger file:
+
+.EX
+2012-09-17 Buy stock
+ Assets:Brokerage < 100 YHOO
+ Basis:YHOO:2012-09-17 > 100 YHOO
+ Assets:Checking > $1568.00
+ Basis:YHOO:2012-09-17 < $1568.00
+
+@ 2012-09-17 YHOO $15.68
+
+2012-11-16 Buy stock
+ Assets:Brokerage < 100 YHOO
+ Basis:YHOO:2012-11-16 > 100 YHOO
+ Assets:Checking > $1786.00
+ Basis:YHOO:2012-11-16 < $1786.00
+
+@ 2012-11-16 YHOO $17.86
+
+2012-12-18 Buy stock
+ Assets:Brokerage < 100 YHOO
+ Basis:YHOO:2012-12-18 > 100 YHOO
+ Assets:Checking > $1982.00
+ Basis:YHOO:2012-12-18 < $1982.00
+
+@ 2012-12-18 YHOO $19.82
+
+@ 2012-12-20 YHOO $19.69
+.EE
+
+You want to see how your investment is doing. Run the following
+command:
+
+.EX
+penny -a Basis:YHOO convert stocks.pny
+.EE
+
+This shows you the current gain or loss on each purchase
+transaction. A credit indicates that your investment has gained value;
+a debit indicates a loss in value.
+
+.SH GAINS AND LOSSES AFTER SALE
+
+When you sell your commodity, record debits and credits agains the same
+.I Basis
+account that you used when purchasing the commodity.
+
+.EX
+2012-01-03 Buy stock
+ Assets:Brokerage < 100 UNP
+ Assets:Checking > $10800.00
+ Basis:UNP:2012-01-03 > 100 UNP
+ Basis:UNP:2012-01-03 < $10800.00
+
+2012-12-28 Sell stock
+ Assets:Brokerage > 100 UNP
+ Assets:Checking < $12354.00
+ Basis:UNP:2012-01-03 < 100 UNP
+ Basis:UNP:2012-01-03 > $12354.00
+.EE
+
+Then you can see the profit or loss on the sale by using the
+.I balance
+report:
+
+.EX
+penny -a Basis:UNP bal stocks.pny
+.EE
+
+This shows a credit balance, indicating a capital gain.
+
+Alternatively, if you don't want to figure out which
+.I Basis
+account to use when selling your commodity, simply use a
+.I Proceeds
+account, and then let
+.BR penny-selloff (1)
+calculate the gain or loss for you:
+
+.EX
+2012-01-03 Buy stock
+ Assets:Brokerage < 100 C
+ Assets:Checking > $3072.00
+ Basis:C:2012-01-03 > 100 C
+ Basis:C:2012-01-03 < $3072.00
+
+2012-12-03 Sell stock
+ Assets:Brokerage > 100 C
+ Assets:Checking < $3901.00
+ Proceeds:C:2012-12-03 < 100 C
+ Proceeds:C:2012-12-03 > $3901.00
+.EE
+
+And then run
+.BR penny-selloff :
+
+.EX
+penny-selloff Proceeds:C:2012-12-03 stocks.pny
+.EE
+
+It will create a transaction for you which will show you the total
+capital gain or loss.
+
+.SH TRACKING CAPITAL ASSETS
+
+You could also use Penny to track a capital asset such as your
+home. This example will get you started:
+
+.EX
+2012-12-31 Buy a house
+ {Assets:Real Estate} < HouseA 1
+ Liabilities:Mortgage > $ 80000.00
+ Assets:Savings > $ 20000.00
+ 'Down payment
+ Basis:House1:2012-12-31 > HouseA 1
+ Basis:House1:2012-12-31 < $ 100000.00
+
+@ 2012-12-31 HouseA $100000.00
+.EE
+
+.SH BUGS
+Report any bugs in the programs or documentation to
+.MT omari@smileystation.com
+Omari Norman
+.ME
+
+.SH SEE ALSO
+.BR penny-suite (1)
diff --git a/doc/man/penny-custom.7 b/doc/man/penny-custom.7
new file mode 100644
index 0000000..afa58fe
--- /dev/null
+++ b/doc/man/penny-custom.7
@@ -0,0 +1,63 @@
+.TH penny-custom 7
+
+.SH NAME
+penny-custom - creating a custom Penny program
+
+.SH DESCRIPTION
+.BR penny (1)
+does not have a configuration file. Instead, it is easy to compile your own
+.B penny
+binary that has the settings you want. The advantage of this
+configuration-file-free approach is that it is easier for me to write
+and means that I don't have to cook up some sort of configuration file
+format. The disadvantage is that you will need to have the Glasgow
+Haskell Compiler (GHC) installed.
+
+Compiling your own
+.B penny
+program can be useful if you find yourself always using some settings,
+and you wish you could set them by default. (Sometimes it may be easy
+to do this using shell aliases, functions, or scripts; other times,
+this might not be so easy.) Also, there are some settings that can
+only be changed by compiling your own
+.B penny
+binary.
+
+These instructions will assume you have the
+.B cabal
+program installed and that you compiled
+.B penny
+from source (currently nobody distributes precompiled
+.B penny
+binaries, so this is a fairly safe assumption.)
+
+All you need to do is download the
+.B penny-bin
+package, or find out where the
+.B penny-bin
+package archive is on your system. Unpack the
+.B penny-bin
+archive, and then edit the
+.I penny.hs
+file. This file is commented so editing it should be fairly simple
+even if you know little or no Haskell.
+
+Then, from the directory that has your
+.I penny-main.hs
+file, run
+.I cabal install
+and you should be all set, if you have already set up the
+.B cabal
+program to install programs to a location that is in your
+path. Alternatively, run
+.I ghc --make -o penny penny-main.hs
+and then you will have a
+.B penny
+binary in the current directory and you can do what you want with it.
+
+.SH BUGS
+Please report any bugs in the programs or documentation to
+omari@smileystation.com.
+
+.SH SEE ALSO
+.BR penny-suite (7)
diff --git a/doc/man/penny-diff.1 b/doc/man/penny-diff.1
new file mode 100644
index 0000000..f39cfd7
--- /dev/null
+++ b/doc/man/penny-diff.1
@@ -0,0 +1,55 @@
+.TH penny-diff 1
+
+.SH NAME
+penny-diff - show differences between two Penny files
+
+.SH SYNOPSIS
+.B penny-diff
+[-12] FILE1 FILE2
+
+.SH DESCRIPTION
+.B penny-diff
+shows the Penny items present in FILE1 that are not present in FILE2,
+as well as the items present in FILE2 that are not present in
+FILE1. An item is a transaction, a price point, or a single-line
+comment. Blank lines are ignored. Differences in the order of items are
+ignored. Because each single-line comment is its own item, no
+difference will be detected if the single-line comments appear in a
+different order in the two files, as long as all the same lines are
+present.
+
+.SH OPTIONS
+.TP
+.B -1
+Show only the items present in FILE1 that are not present in FILE2.
+
+.TP
+.B -2
+Show only the items present in FILE2 that are not present in FILE1.
+
+.SH VERSUS diff(1)
+You could do this with
+.BR diff (1).
+The biggest difference is that
+.B penny-diff
+understands and parses the ledger file, while
+.B diff
+does not. Experiment with the two programs to see which works better in your situation (and take note of options in
+.B diff
+such as
+.IR -b " and " -w ,
+which can ignore some whitespace changes.)
+
+.SH EXIT STATUS
+0 if there are no differences between FILE1 and FILE2; 1 if there are
+differences; 2 if there was some problem (such as a file that could
+not be parsed.)
+
+.SH BUGS
+Please report bugs in the program or documentation to
+.MT omari@smileystation.com
+Omari Norman.
+.ME
+
+.SH SEE ALSO
+.BR penny-suite (7)
diff --git a/doc/man/penny-examples.7 b/doc/man/penny-examples.7
new file mode 100644
index 0000000..1ec03e4
--- /dev/null
+++ b/doc/man/penny-examples.7
@@ -0,0 +1,107 @@
+.TH penny-examples 7
+
+.SH NAME
+penny-examples - more examples of Penny usage
+
+.SH DESCRIPTION
+This page contains more examples of the use of
+.BR penny (1).
+At first you will want to read
+.BR penny-basics (1)
+as there are also many useful examples there.
+
+.SH SHOWING DIFFERENT FIELDS
+
+Each posting has many characteristics, called
+.BR fields .
+For example, a posting has an account, and perhaps a payee and a
+flag. Only some fields are shown in the
+.B postings
+report by default;
+.BR penny (1)
+tells you which ones these are, as well as the additional fields you
+can show. To show additional fields, use the --show option. For
+instance, showing the line numbers of a posting can be handy if you
+want to track the postings down in your ledger:
+
+.EX
+penny --account assets:checking postings \\
+ --show lineNum starter.pny
+.EE
+
+This adds the line number to each posting. As you can see if you try
+it out, the option does not remove any fields. If you want to start
+from a clean slate, try the
+.I --hide-all
+option.
+
+The width of the report adjusts automatically to accomodate the fields
+you want, while fitting them to the width of your screen. Most fields
+are simply as wide as they need to be to show their information;
+however, the
+.I payee
+and
+.I account
+fields will wrap to multiple lines or squeeze themselves smaller by
+eliminating letters (respectively) in order to help the report fit in
+the width of your screen.
+
+.SH FITERING BASED ON SIBLINGS
+
+Each transaction has at least two postings. The postings in a single
+transaction are called
+.IR siblings .
+When
+.I penny
+first runs, it splits each transaction into postings. Then it
+generally deals with each posting independently. However,
+.I penny
+"remembers" which siblings each posting has. You can then use a
+posting's siblings as criteria when you are building a filter
+expression.
+
+For example, you want to see all the activity in your checking
+account. First you try this:
+
+.EX
+penny --account assets:checking postings starter.pny
+.EE
+
+This tells you each time your checking account is debited or
+credited--which is quite useful. But maybe you want to know what
+expenses you are paying for out of your checking account. The report
+above is not too useful for that as the account is always the same:
+.IR Assets:Checking .
+What you want to see is the sibling postings each time there is
+activity in your checking account. Try this:
+
+.EX
+penny --s-account assets:checking postings starter.pny
+.EE
+
+This works by selecting each posting that has a sibling posting with
+the account
+.IR Assets:Checking .
+All postings are included, even those that are deposits, like
+those from
+.IR Income:Salary .
+If you only want to see sibling postings that are also in an Expenses
+account:
+
+.EX
+penny --s-account assets:checking \\
+ --and --account expenses postings starter.pny
+.EE
+
+Alternatively, you can see each posting that has a sibling posting
+that is in the Assets:Checking account and where the posting itself is
+a debit:
+
+.EX
+penny --s-account assets:checking \\
+ --and --debit postings starter.pny
+.EE
+
+.SH SEE ALSO
+.BR penny (1),
+.BR penny-suite (7)
diff --git a/doc/man/penny-fit.7 b/doc/man/penny-fit.7
new file mode 100644
index 0000000..c2425b2
--- /dev/null
+++ b/doc/man/penny-fit.7
@@ -0,0 +1,375 @@
+.TH penny-fit 7
+.
+.SH NAME
+penny-fit - Penny financial institution statements parser
+.
+.SH SYNOPSIS
+.B penny-fit
+[global-options] COMMAND [local-options] ARGS
+.
+.SH DESCRIPTION
+.
+.B penny-fit
+works with data you have downloaded from your financial
+institution.
+.
+It parses statements that you have downloaded and adds
+transactions from the statements to your ledger, skipping those that
+have already been added.
+.
+It also helps you reconcile your ledger with
+financial institution statements.
+.
+.P
+First you will have to configure and compile a
+.B penny-fit
+binary.
+.
+You can use the
+.B penny-fit-sample.hs
+file in the
+.I doc
+directory of the
+.B penny-bin
+package as an example.
+.
+Alternatively, if you know your way around Haskell, see the Haddock
+documentation for the
+.I Penny.Brenner
+module.
+.
+The comments in that file should help you get
+started.
+.
+.P
+Currently Penny includes a parser for Open Financial
+Exchange, or OFX, data.
+.
+Many banks make information available in this
+format, as Quicken and the now-defunct Microsoft Money both support
+the format.
+.
+.SH IMPORTING
+.
+To use
+.BR penny-fit ,
+first you will download the appropriate data from your financial
+institution and place it in a file.
+.
+.I penny-fit info
+will tell give you a little more information about the place to look
+on your institution's web site to download the data, if you have
+configured that information in your binary.
+.
+.P
+Then, run
+.IR "penny-fit -f ACCOUNT import FILENAME" .
+The first time you run this command, you will have to add the
+.I --new
+option after the
+.I import
+command, which allows the creation of a new database.
+.
+Without this
+option, if the database is not found,
+.B penny-fit
+quits with an error message.
+.
+The ACCOUNT must be a financial
+institution account that you configured in your
+.B penny-fit
+binary (if you configured a default account and you want to use that,
+you can omit the
+.I -f
+option).
+.
+The FILENAME is the location of the data that you just
+downloaded.
+.
+.P
+The
+.I import
+command will examine the data that you downloaded.
+.
+Using the unique
+identifiers already assigned to each posting by your financial
+institution, the
+.I import
+command determines whether you have already downloaded each particular
+posting.
+.
+If the posting is new,
+.I import
+assigns a different, unique number to the posting.
+.
+This is called a
+.IR U-number .
+The U-number allows you to uniquely identify each posting that you
+download.
+.
+The data from the financial institution, along with the
+U-number, is added to a database at the location specified in your
+configuration.
+.I import
+automatically skips postings that have already been processed, so you
+do not have to worry about importing duplicate postings.
+.
+.SH MERGING
+.
+Next you will want to merge new postings into your ledger.
+.
+Do this by
+running
+.I penny-fit -f ACCOUNT merge LEDGER_FILE...
+where LEDGER_FILE is one or more filenames for your ledger files.
+.
+.I merge
+examines your ledgers to see if each of the postings in the database
+for this financial institution is represented in your ledger.
+.
+To do
+this it looks at the postings in the
+.I pennyAcct
+specified in your configuration.
+.
+For each U-number in the database,
+.I merge
+sees if there is a posting in the
+.I pennyAcct
+with a tag bearing the U-number (e.g. if the U-number is 5, it looks
+for the tag
+.IR U5 ).
+If a posting has more than one U-number tag, only the first is used;
+the others are ignored.
+.
+If such a posting is found,
+.I merge
+moves on to the next U-number in the database.
+.
+If no matching posting is found for a U-number,
+.I merge
+sees if there is a matching posting that does
+.I not
+have a U-number tag.
+.
+If there is a posting in the
+.I pennyAcct
+that has the same quantity and date as the financial institution
+posting,
+.I merge
+will then examine the debit or credit of the ledger posting.
+.
+.P
+This table describes whether
+.I penny-fit
+will find a match:
+.
+.TS
+tab(:);
+l l l l
+- - - -
+l l l l.
+T{
+If the financial institution posting is a
+T}:T{
+and translator is
+T}:T{
+and the ledger posting is a
+T}:T{
+then is there a match?
+T}
+increase:IncreaseIsDebit:debit:Yes
+increase:IncreaseIsDebit:credit:No
+increase:IncreaseIsCredit:debit:No
+increase:IncreaseIsCredit:credit:Yes
+decrease:IncreaseIsDebit:debit:No
+decrease:IncreaseIsDebit:credit:Yes
+decrease:IncreaseIsCredit:debit:Yes
+decrease:IncreaseIsCredit:credit:No
+.TE
+.
+.P
+If
+.B penny-fit
+finds a match for a financial institution posting in this way, then it
+will assign a new U-number tag to the posting.
+.
+If
+.B penny-fit
+does not find a match, then it will create an entirely new transaction
+and append it to the end of your ledger.
+.
+.P
+If it is creating an entirely new transaction,
+.B penny-fit
+will attempt to give the new transaction the same account and payee
+information that you have used for similar transactions in the
+past.
+.
+To do this,
+.B penny-fit
+will first search through the database to find the most recent
+financial institution posting that has the same payee as the one of
+the new transaction. If one is found,
+.B penny-fit
+then searches through the postings in your ledger file to find the one
+that has the same U-number and account as the old financial
+institution posting.
+.
+If it is found,
+.B penny-fit
+will assign the payee name found on the posting in the ledger to the
+new posting.
+.
+Also, if the posting found in the ledger has exactly one
+sibling posting,
+.B penny-fit
+will assign the same account name from that sibling to the new
+sibling.
+.
+You can turn off this automatic assignment of information by using the
+.I --no-auto
+or
+.I -n
+option to the
+.I merge
+command.
+.
+.P
+The result of
+.I merge
+is printed to standard output, unless you use the
+.I --output FILENAME
+or
+.I -o FILENAME
+option, in which case the output is sent to
+.IR FILENAME .
+.
+You can use multiple
+.I -o
+options.
+.
+To explicitly send output to standard output, use
+.IR "-o -" .
+.
+Use
+.BR diff (1)
+or
+.BR penny-diff (1)
+to see what changes
+.I merge
+made.
+.
+Typically you will need to edit the output somewhat.
+.
+.SH RECONCILING
+.
+Next you may wish to reconcile your ledger with your financial
+institution data (that is, "balance the checkbook").
+.
+Typically the
+most time-consuming part of this process is finding the postings in
+your ledger that match the postings on your bank statement.
+.
+.B penny-fit clear
+will help with this, dramatically speeding up the process.
+.
+To do
+this, download data from your financial institution that corresponds
+to the data that is covered within the current statement period.
+.
+Run
+.B penny-fit import
+and
+.B penny-fit merge
+as described above. Then run
+.
+.P
+.EX
+penny-fit -f ACCOUNT clear FIT_FILE LEDGER_FILE...
+.EE
+.
+.P
+where FIT_FILE is the data file you downloaded from your financial
+institution, and LEDGER_FILE contains your ledger data.
+.
+The
+.I clear
+command will mark as cleared (that is, assign a
+.I C
+flag to) all postings in your LEDGER_FILEs that correspond to one of
+the postings in the FIT_FILE.
+.
+It does this by matching the U-number
+tags on your postings to the U-numbers in the database.
+.
+If a posting
+has more than one U-number tag, only the first is used; the others are
+ignored.
+.
+.P
+As with the
+.I merge
+command, the results are printed to standard output unless you use the
+.I --output FILENAME
+or
+.I -o FILENAME
+option.
+.
+Once you have verified that things
+are as they should be, you can use
+.BR penny-reconcile (1)
+to mark the cleared postings as reconciled.
+.
+.BR penny-basics (7)
+has more details on how to use
+.B penny
+when reconciling a financial institution statement.
+.
+.SH OTHER COMMANDS
+.
+The
+.I database
+command prints the database for a particular financial institution to
+standard output in human-readable form (the database unfortunately is
+not in plain human-readable text).
+.
+For instance you might use this to
+see what U-number is assigned to a particular financial institution
+posting.
+.
+.P
+The
+.I print
+command parses a downloaded file of financial institution data and
+prints the result to standard output.
+.
+This is useful for seeing the
+contents of a financial institution data file, or for testing new
+parsers.
+.
+.P
+Every
+.B penny-fit
+command has a
+.I -h
+and a
+.I --help
+option.
+.
+There is also a global
+.I --help
+option, as in
+.IR "penny-fit --help" .
+.
+.SH BUGS
+To quote another man page: "Bugs?
+.
+You must be kidding, there are no
+bugs in this software.
+.
+But if we happen to be wrong, send us an email
+with as much detail as possible to" omari@smileystation.com.
+.
+.SH SEE ALSO
+.BR penny-suite (7)
diff --git a/doc/man/penny-reconcile.1 b/doc/man/penny-reconcile.1
new file mode 100644
index 0000000..98e4482
--- /dev/null
+++ b/doc/man/penny-reconcile.1
@@ -0,0 +1,100 @@
+.TH penny-reconcile 1
+.
+.SH NAME
+penny-reconcile - mark cleared postings as reconciled
+.
+.SH SYNOPSIS
+.B penny-reconcile
+[options]
+FILE...
+.
+.SH DESCRIPTION
+Finds all postings in the input ledger files whose flag is exactly one
+letter: the letter
+.IR C .
+Changes those flags to the letter
+.I R
+and prints the resulting ledger to standard output.
+.
+.P
+This is useful
+when reconciling a financial institution account: you may first mark
+postings in your ledger that match a posting on your bank statement
+with a
+.I C
+flag.
+.
+Because only postings from the current statement will be marked with a
+.I C
+flag, it is easier to use
+.BR penny (1)
+to list only the postings that you have just cleared.
+.
+Then, after
+ensuring that the statement is properly reconciled,
+.B penny-reconcile
+will automatically mark all the posts reconciled.
+.
+.P
+If no
+.IR FILE ", or " FILE " is " - ,
+read standard input.
+.
+.SH OPTIONS
+.
+.TP
+.IR "--output FILENAME", " -o FILENAME"
+.
+send output to
+.I FILENAME
+instead of standard output.
+.
+You can use multiple
+.I --output
+options; to explicitly print to standard output, use
+.IR "--output -" .
+.
+.SH VERSUS sed(1) OR YOUR TEXT EDITOR
+You could do this with
+.BR sed (1)
+or your text editor.
+.
+Unlike those programs,
+.B penny-reconcile
+knows the structure of a ledger file.
+.
+So
+.B penny-reconcile
+will not, for example, change the text
+.IR [C] " to " [R]
+where the
+.I [C]
+appears within a comment, while a naive
+.BR sed (1)
+script would do so.
+.
+This would happen only rarely though, so you might
+be just fine using a query-replace function in your text editor.
+.
+.P
+Also,
+.B penny-reconcile
+will tidy up your ledger file--that is, it might rearrange or delete
+the non-significant whitespace within a transaction and posting, similar to
+.BR penny-reprint (1).
+This might be good or bad.
+.BR sed (1)
+or your text editor, on the other hand, will not do this.
+.
+.SH EXIT STATUS
+0 if everything went fine; some other value if something went wrong
+(e.g. a ledger file could not be parsed.)
+.
+.SH BUGS
+Please report bugs in the program or documentation to
+.MT omari@smileystation.com
+Omari Norman.
+.ME
+.
+.SH SEE ALSO
+.BR penny-suite (7)
diff --git a/doc/man/penny-reprint.1 b/doc/man/penny-reprint.1
new file mode 100644
index 0000000..c716906
--- /dev/null
+++ b/doc/man/penny-reprint.1
@@ -0,0 +1,53 @@
+.TH penny-reprint 1
+.
+.SH NAME
+penny-reprint - read and reprint Penny ledger
+.
+.SH SYNOPSIS
+.B penny-reprint
+[options]
+.I FILE...
+.
+.SH DESCRIPTION
+.
+Reads the Penny ledger(s) you specify and prints them to standard
+output, in a (hopefully) more tidy format.
+.
+All comments are retained,
+but blank lines and insignicant whitespace within the transactions
+(such as the amount of whitespace between multiple tags) are ignored.
+.
+If no
+.IR FILE ,
+or
+.I FILE
+is
+.IR - ,
+read standard input.
+.
+.SH OPTIONS
+.
+.TP
+.IR "--output FILENAME", " -o FILENAME"
+.
+send output to
+.I FILENAME
+instead of standard output.
+.
+You can use multiple
+.I --output
+options; to explicitly print to standard output, use
+.IR "--output -" .
+.
+.SH EXIT STATUS
+0 if everything went fine; another value if there were problems (such
+as inability to read a ledger file.)
+.
+.SH BUGS
+Please report any bugs in the program or documentation to
+.MT omari@smileystation.com
+Omari Norman
+.ME
+.
+.SH SEE ALSO
+.BR penny-suite (7)
diff --git a/doc/man/penny-selloff.1 b/doc/man/penny-selloff.1
new file mode 100644
index 0000000..3200e21
--- /dev/null
+++ b/doc/man/penny-selloff.1
@@ -0,0 +1,85 @@
+.TH penny-selloff 1
+
+.SH NAME
+penny-selloff - calculate capital gains and losses from commodity sales
+
+.SH SYNOPSIS
+.B penny-selloff
+.I PROCEEDS-ACCOUNT FILE...
+
+.SH DESCRIPTION
+
+This is a description of how
+.B penny-selloff
+works. You will be lost if you have not read
+.BR penny-commodities (7)
+and looked at the
+.I stocks.pny
+file in the
+.I examples
+directory of the
+.I penny-bin
+tarball.
+
+.B penny-selloff
+examines the names of the sub-accounts of the
+.IR PROCEEDS-ACCOUNT .
+The first sub-account name is ignored (typically it will be
+.IR Proceeds .)
+The second sub-accont is the
+.I group
+(typically it will be the name of the commodity you are selling,
+though it does not have to be.) The third sub-account is the date
+(and, optionally, the time) when you sold the commodity.
+
+.B penny-selloff
+then parses all the ledger files given on the command line. (If no
+files are given, or if a file is
+.IR - ,
+it reads standard input.)
+Then
+.B penny-selloff
+examines the balance of the proceeds account. It must have exactly one
+debit amount and one credit amount in the balance. The debit balance
+is the commodity you are selling. The credit balance is the commodity
+you received in return for the sale (typically your home currency.)
+
+Next,
+.B penny-selloff
+examines the balances of all accounts in the parsed ledger files. It
+finds accounts that have
+.I Basis
+as the first sub-account and whose second sub-account matches the
+.I group
+found in the proceeds account (again, typically this will be the name
+of the commodity you are selling, though it does not have to be.) The
+third sub-account must be a date and optional time, which was when the
+commodity was purchased. Each of these accounts must have one debit
+amount, which is the cost of the purchase, and a credit balance, which
+is the amount of the commodity that was purchased.
+
+Finally,
+.B penny-selloff
+computes postings that will eliminate the balances of the
+.I Basis
+accounts. It also computes the capital gain or loss from each
+sale. The oldest commodities are sold first.
+
+.B penny-selloff
+creates a single transaction with postings that eliminate the balances
+.I Basis
+accounts corresponding to the commodities that were sold. The
+transaction also contains postings with the capital gain or loss from
+each sale. This transaction is printed to standard output.
+
+.SH EXIT STATUS
+0 if everything went fine; non-zero if there was a problem.
+
+.SH BUGS
+Please report bugs in the program or documentation to
+.MT omari@smileystation.com
+Omari Norman.
+.ME
+
+.SH SEE ALSO
+.BR penny-suite "(7), " penny-commodities (7)
diff --git a/doc/man/penny-suite.7 b/doc/man/penny-suite.7
new file mode 100644
index 0000000..d3b6222
--- /dev/null
+++ b/doc/man/penny-suite.7
@@ -0,0 +1,136 @@
+.TH penny-suite 7
+.
+.SH NAME
+penny-suite - extensible double-entry accounting system
+.
+.SH DESCRIPTION
+.
+This manual page lists all the different components of Penny and also
+catalogues all the documentation files and manual pages that are
+available.
+.
+.SH PENNY PROGRAMS
+.
+Penny consists of many programs. Each has its own manual page.
+.
+.TP
+.BR penny (1)
+.
+reports on postings in your ledger file
+.
+.TP
+.BR penny-selloff (1)
+.
+calculate capital gains and losses on commodity sales
+.
+.TP
+.BR penny-diff (1)
+.
+show differences between ledger files
+.
+.TP
+.BR penny-reprint (1)
+.
+tidy up a ledger file, retaining comments
+.
+.TP
+.BR penny-reconcile (1)
+.
+marks cleared postings as reconciled
+.
+.SH PENNY MANUAL PAGES
+.
+In addition to the manual pages shown above, a few more overview man
+pages are available.
+.
+.TP
+.BR penny-basics (7)
+.
+getting started with
+.B penny
+.
+.TP
+.BR penny-examples (7)
+.
+more examples of
+.B penny
+usage
+.
+.TP
+.BR penny-commodities (7)
+.
+tracking multiple commodities, such as stocks, with Penny
+.
+.TP
+.BR penny-fit (1)
+.
+describes how you might be able to create a program that automatically
+parses downloaded statements from your financial institution and
+merges the resulting postings into your ledger file.
+.
+.TP
+.BR penny-custom (7)
+.
+how to make a custom \fBpenny\fR program with your own settings
+.
+.SH SAMPLE FILES
+.
+There are many files available filled with sample data. They are in the
+.I examples
+directory of the
+.B penny-bin
+tarball.
+.
+.TP
+.BR starter.pny
+.
+describes the basics of the Penny ledger file format, and contains
+sample data. The
+.BR penny-basics (7)
+manual page uses the sample data from this file.
+.
+.TP
+.BR stocks.pny
+.
+shows how to use Penny to track multiple commodities, like stocks
+.
+.TP
+.BR stocks-realized.pny
+.
+shows an example of the results of using
+.BR penny-selloff (1)
+.
+.
+.SH TEXT FILES
+.
+Much documentation is available only in plain-text form. These files
+are in the
+.B doc
+directory of the
+.B penny-bin
+tarball.
+.
+.TP
+.BR amex-file-format.org
+.
+the file format American Express uses for its downloadable data
+.
+.TP
+.BR bofa-file-format.org
+.
+the file format Bank of America uses for its downloadable data
+.
+.TP
+.BR dependencies.dot
+.
+the dependencies between the various parts of the Penny library
+.
+.TP
+.BR ledger-grammar.org
+.
+an EBNF grammar for the ledger file format
+.
+.SH HADDOCK
+.
+Feel free to examine the Haskell source code of the Penny library,
+which also contains Haddock documentation markup.
diff --git a/doc/man/penny.1 b/doc/man/penny.1
new file mode 100644
index 0000000..d870cc2
--- /dev/null
+++ b/doc/man/penny.1
@@ -0,0 +1,815 @@
+.TH penny 1
+
+.SH NAME
+penny - report on postings in financial ledger
+
+.SH SYNOPSIS
+penny [global options] report name [report options] FILE...
+
+.SH DESCRIPTION
+
+This manual page is a complete reference for the operation of
+.BR penny .
+To get started, see
+.BR penny-getting-started (1).
+
+The
+.B penny
+program prepares reports based upon the
+.B postings
+in your ledger file. Each transaction has at least two postings. After
+.B penny
+verifies that your ledger file is
+.I balanced
+(that is, every transaction has debits and credits that are equal)
+.B penny
+splits each transaction into its component postings. After this point,
+.B penny
+for the most part deals only with postings, not with transactions.
+
+You may specify
+.IR "global options" .
+Most global options allow you to create a
+.I filter expression
+that determines which postings are ultimately used for the report. The
+filter expression may also contain additional options that perform
+tasks other than filtering. For example, you may specify how to
+perform text matching (for instance, you may want to use regular
+expressions) or you may specify that you want to sort the postings (by
+default, they are not sorted and are left in the order in which they
+were found in the input ledger).
+
+Other global options control the color scheme of the report and
+whether colors are used at all.
+
+Next you must specify a
+.IR report .
+Currently there are three reports. The
+.BR postings
+report shows information about each posting, like a checkbook register.
+There are two reports that show account balances only: the
+.BR balance
+report and the
+.B convert
+report. Each report shows only the postings returned by the posting
+filter expression.
+
+You may then specify options pertaining to the report. The
+.BR postings
+report takes many options that format its output and that specify
+which postings are shown in the report; however, postings that the
+filter expression returned that are not shown in the report still
+affect the running balance. This can be useful if, for example, you
+want to see the total balance in your bank account and how some
+transactions affect it but you do not want to see all transactions
+since the beginning of time. The
+.BR balance
+and
+.B convert
+reports take many fewer options.
+
+Finally you may specify one or more files from which to draw the
+data. If you do not specify a file, standard input is used. The report
+is always printed to standard output.
+
+Entering the data into the ledger files is your responsibility;
+.B penny
+will never modify this data. To see how to enter data into the file,
+see the file
+.BR examples/starter.pny ,
+which is included inside the package for
+.BR penny-bin .
+
+.SH COMPARERS
+
+Many options perform comparisons; for example, the
+.B --date
+option compares postings to a date you specify to determine
+which postings to keep and which to reject. Where
+.I comparer
+appears below, you must supply one of the following strings.
+You will need to quote many of them, because many of these
+characters will have special meaning for your shell.
+
+.TS
+tab(:);
+l l l
+- - -
+lB lB l.
+Primary form:Alternate form:Comparison performed
+<::Less than
+<=::Less than or equal to
+==:T{
+=
+T}:Equals
+>::Greater than
+>=::Greater than or equal to
+/=:!=:Not equal to
+.TE
+
+.SH DISPLAY OPTIONS
+
+.TP
+.BI "--scheme " SCHEME_NAME
+Use the given color scheme. By default, three schemes are available:
+.IR dark ,
+designed for dark-background terminals,
+.IR light ,
+for light-background terminals, and
+.IR plain ,
+which uses the terminal's default colors.
+By default the
+.I dark
+scheme is used.
+
+.TP
+.BI "--color-to-file " "no|yes"
+Whether to use color when standard output is not a terminal. Default is
+.IR no .
+If standard output is a terminal, the maximum color capabilities of your terminal are used. (If you do not like color, preface your
+.B penny
+command with
+.IR TERM=dumb
+or, alternatively, use
+.BR "--scheme plain" ,
+which has the same effect.)
+
+.SH POSTING FILTERS
+.SS Dates
+
+.TP
+.BI "--date | -d " "comparer timespec"
+
+The date of the posting must be within the time frame given.
+.BR date
+is the same format as dates in the
+.B penny
+file and
+is either a date alone, such as
+.BR 2012-04-25 ,
+or a date and a time, such as
+.BR "2012-04-25 14:25 -0400" .
+
+.TP
+.B --current
+Same as
+.BI "--date <= " "right now"
+
+.SS Serials
+These perform matching based on serials. For more on serials,
+see the section
+.B SERIALS
+below. Each option takes the form
+.IR "option comparer number" .
+.TP
+.B --globalTransaction
+.TQ
+.B --revGlobalTransaction
+.TQ
+.B --globalPosting
+.TQ
+.B --revGlobalPosting
+.TQ
+.B --fileTransaction
+.TQ
+.B --revFileTransaction
+.TQ
+.B --filePosting
+.TQ
+.B --revFilePosting
+
+.SS Pattern matching
+
+These options allow you to filter postings by specifying a pattern
+that must match a particular component of the posting. By default the simple
+.I within
+matcher is used, and matches are case-insensitive.
+
+.TP
+.BI "--account | -a " pattern
+The sub-accounts of the account are separated with colons, and the
+match succeeds if the pattern matches this entire colon-separated
+name.
+
+.TP
+.BI "--account-level " "number pattern"
+The account is separated into sub-accounts, which are numbered
+beginning at zero. The match succeeds if the posting has a sub-account
+numbered at the given level, and if that sub account matches the given
+pattern.
+
+.TP
+.BI --account-any " pattern"
+The account is separated into sub-accounts. The match succeeds if the
+pattern matches any of a posting's sub-accounts.
+
+.TP
+.BI "--payee | -p " pattern
+Succeeds if the pattern matches the posting's payee. If the posting
+has no payee, the payee of the parent transaction is used (if there is
+one).
+
+.TP
+.BI "--tag | -t " pattern
+Succeeds if any one of the posting's tags matches the given pattern.
+
+.TP
+.BI "--number | -n " pattern
+Succeeds if the posting's number matches the given pattern. (This is
+the number that you specify in parentheses in your ledger file, not
+the line number or any of the serial numbers.) If the posting has no
+number, the number of the parent transaction is used (if there is
+one).
+
+.TP
+.BI "--flag | -f " pattern
+Succeeds if the posting's flag matches the given pattern. If the
+posting has no number, the flag of the parent transaction is used
+(if there is one).
+
+.TP
+.BI "--commodity | -y " pattern
+Succeeds if the posting's commodity matches the given pattern.
+
+.TP
+.BI "--posting-memo " pattern
+The posting memo must match the given pattern. For the purpose of this
+option, the line breaks in the posting memo are replaced with spaces.
+
+.TP
+.BI "--transaction-memo " pattern
+The transaction memo must match the given pattern. For the purpose of
+this option, the line breaks in the transaction memo are replaced with
+spaces.
+
+.SS Other posting characteristics
+
+.TP
+.B --debit
+The entry must be a debit.
+
+.TP
+.B --credit
+The entry must be a credit.
+
+.TP
+.BI "--qty | -q " "comparer number"
+The entry's quantity must fall within the given range.
+
+.TP
+.BI "--filename " pattern
+The filename from which the entry came must match this pattern.
+
+.SS Sibling postings
+
+All of the postings in a transaction are known as
+.IR siblings .
+Because every transaction has at least two postings, every posting has
+at least one sibling. The options given above examine the
+characteristics of a posting. The following options examine the
+characteristics of the siblings of a posting; the option will match
+the posting if any of its siblings match the specified
+information. Otherwise, these options behave similarly to the
+corresponding option which does not have the
+.I --s-
+prefix. Not every filter option has a corresponding
+.I --s-
+option; for example, there is no
+.I --s-date
+option because all sibling postings have the same date.
+
+.TP
+.BI "--s-globalPosting"
+
+.TP
+.BI "--s-revGlobalPosting"
+
+.TP
+.BI "--s-filePosting"
+
+.TP
+.BI "--s-revFilePosting"
+
+.TP
+.BI "--s-account"
+
+.TP
+.BI "--s-account"
+
+.TP
+.BI "--s-account-level"
+
+.TP
+.BI "--s-account-any"
+
+.TP
+.BI "--s-payee"
+
+.TP
+.BI "--s-tag"
+
+.TP
+.BI "--s-number"
+
+.TP
+.BI "--s-flag"
+
+.TP
+.BI "--s-commodity"
+
+.TP
+.BI "--s-posting-memo"
+
+.TP
+.BI "--s-debit"
+
+.TP
+.BI "--s-credit"
+
+.TP
+.BI "--s-qty"
+
+.SS Operators
+
+Each of the options above is a single operand. If you have multiple
+operands, you must join them together using operators. You may use
+either infix or reverse polish notation when joining operators (infix
+is the default.) When using the
+.B --infix
+or
+.B --rpn
+option, the option may appear anywhere within the posting filter
+expression.
+.
+.TP
+.B --infix
+Use infix operators (default)
+.
+.TP
+.B --rpn
+Use reverse polish notation
+.
+.SS Infix Operators
+These are the infix operators, from highest to lowest precedence. All
+operators are left associative.
+.
+.TP
+.BI "--open " expr " --close"
+.TQ
+.BI "-( " expr " -)"
+Force precedence using parentheses. Enclose a complete expression
+between the
+.B --open
+and
+.B --close
+options.
+
+.TP
+.BI "--not " expr
+.TQ
+.BI "-N " expr
+True if
+.I expr
+is false.
+
+.TP
+.IB expr1 " --and " expr2
+.TQ
+.IB expr1 " -A " expr2
+True if
+.I expr1
+and
+.I expr2
+are both true.
+
+.TP
+.IB expr1 " --or " expr2
+.TQ
+.IB expr1 " -O " expr2
+True if
+.I expr1
+or
+.I expr2
+is true.
+.
+.SS Reverse polish notation operators
+.
+When using RPN, each of the operands shown above pushes that operand
+onto the stack. Each operand is a predicate; you can assemble these
+predicates into larger predicates. Using the
+.B --open
+or
+.B --close
+options with RPN is an error.
+.
+.TP
+.B --and
+.TQ
+.B -A
+Pops two predicates from the top of the stack, creates a new predicate
+which is true only if both predicates are true, and pushes the new
+predicate onto the stack.
+.
+.TP
+.B --or
+.TQ
+.B -O
+Pops two predicates from the top of the stack, creates a new predicate
+which is true if either predicate is true, and pushes the new
+predicate onto the stack.
+.
+.TP
+.B --not
+.TQ
+.B -N
+Pops one predicate from the top of the stack, creates a new predicate
+which is true if the original predicate is false, and pushes the new
+predicate onto the stack.
+.
+.SS Options affecting patterns
+
+These options affect how patterns are interpreted. The order of the
+.B penny
+command line is significant; each of these options only affects
+patterns that appear after it on the command line.
+
+.TP
+.B "-i | --case-insensitive"
+Patterns are case insensitive (default)
+
+.TP
+.B "-I | --case-sensitive"
+Patterns are case sensitive
+
+.TP
+.B "--within | -w"
+Use the "within" matcher (default), which matches if the pattern given
+appears anywhere within the target text. This is a simple
+letter-for-letter match, not a regular expression, though its case
+sensitivity is affected by the
+.B --case-insensitive
+and
+.B --case-sensitive
+options.
+
+.TP
+.B "--pcre | -r"
+Use the "pcre" matcher, which uses Perl-compatible regular expressions (see
+.BR pcresyntax "(3) and " pcrepattern (3))
+
+.TP
+.B --posix
+Use the "posix" matcher, which uses POSIX regular expressions (see
+.BR regex (7))
+
+.TP
+.B "--exact | -x"
+Use the "exact" matcher, which matches if the given pattern is a
+letter-for-letter match of the target text, with case sensitivity
+determined by the
+.B --case-insensitive
+and
+.B --case-sensitive
+options.
+
+.SH SHOWING EXPRESSIONS AND RESULTS
+.
+.TP
+.B \-\-show\-expression
+.
+.P
+Show the parsed posting filter expression.
+.
+.TP
+.B \-\-verbose-filter
+.
+.P
+Verbosely show the results of running the posting filter.
+This will show you each posting, telling you whether the
+posting filter accepted or rejected the posting and why.
+.
+.
+.SH REMOVING POSTINGS AFTER SORTING AND FILTERING
+
+.TP
+.BI "--head " n
+Keep only the first
+.I n
+postings.
+
+.TP
+.BI "--tail " n
+Keep only the last
+.I n
+postings.
+
+.SH SORTING
+
+.TP
+.BI "--sort | -s " key
+Sorts postings according to a key. Use multiple
+.B --sort
+options to sort by more than one key. Valid keys are: payee, date,
+flag, number, account, drCr, qty, commodity, postingMemo,
+transactionMemo.
+
+The postings are sorted in ascending order if the first letter of the
+key is lowercase; descending order if the first letter of the key is
+uppercase.
+
+Postings by default are sorted by date in ascending order; however,
+any specification of a
+.B --sort
+option on the command line overrides this. For example,
+.B --sort payee
+sorts postings by payee from A-Z, while
+.B --sort date --sort payee
+sorts postings by date from oldest to newest and sorts postings with
+the same date in payee order from A to Z.
+
+If you want to leave postings in the order in which they appeared in
+your ledger file, use
+.BR "--sort none" .
+
+
+.SH META
+.TP
+.B --help | -h
+Show help and exit. If you have configured a custom
+.B penny
+binary (see
+.BR penny-custom (7))
+you might have established defaults that differ from the defaults
+described in this manual page. The output of
+.B penny --help
+will reflect these customizations.
+.TP
+.B --version
+Show version of the executable and of the
+.B penny-lib
+library (the library might have a different version number).
+
+.SH POSTINGS REPORT
+
+The
+.B postings
+report, or
+.B pos
+for short, shows postings in order with a running balance. This report
+takes all the options shown above in the categories from "Posting
+filters" through "Removing postings after sorting and filtering." These
+options affect which postings are shown in the report. Postings that
+are not shown in the report but which were not filtered out in the
+filtering stage still affect the report's running balance.
+
+Additional options for the
+.B postings
+report:
+
+.SS Additional serial filtering options
+These options affect which postings are shown. Postings that were not
+filtered in the filtering stage but that are not shown still affect
+the running balance. In addition to using the same options that are
+used for filtering, these additional options are available that are
+based on some additional serials. They take the form
+.IR "option comparer number " .
+For more information on serials, see the
+.B SERIALS
+section below.
+
+.TP
+.B --filtered
+filtered serial, forward component
+.TP
+.B --revFiltered
+filtered serial, reverse component
+.TP
+.B --sorted
+sorted serial, forward component
+.TP
+.B --revSorted
+sorted serial, reverse component
+
+.SS Other additional options for the postings report
+
+.TP
+.BI --width " num"
+Gives a hint for roughly how wide the report should be, in
+columns. (By default the
+.I COLUMNS
+environment variable is used.)
+
+.TP
+.BI "--show" " field"
+.TQ
+.BI "--hide" " field"
+Show or hide fields from the displayed report. Fields are displayed in
+a fixed order, which is the same as the order that the table below is
+in. Fields with an asterisk are shown by default.
+
+.\" Do not precede the empty fields in the table with any spaces. This
+.\" will cause GNU tbl to segfault.
+.\" See
+.\" http://lists.gnu.org/archive/html/groff/2010-11/msg00014.html
+.\" Apparently the bug has been fixed but who knows how long that will
+.\" take to propogate.
+
+.TS
+tab(:);
+lB lB l.
+:globalTransaction:globalTransaction serial, forward component
+:revGlobalTransaction:globalTransaction serial, reverse component
+:globalPosting:globalPosting serial, forward component
+:revGlobalPosting:globalPosting serial, reverse component
+:fileTransaction:fileTransaction serial, forward component
+:revFileTransaction:fileTransaction serial, reverse component
+:filePosting:filePosting serial, forward component
+:revFilePosting:filePosting serial, reverse component
+:filtered:filtered serial, forward component
+:revFiltered:revFiltered serial, reverse component
+:sorted:sorted serial, forward component
+:revSorted:sorted serial, reverse component
+:visible:visible serial, forward component
+:revVisible:visible serial, reverse component
+:lineNum:line number (starting from 1)
+*:date:transaction's date
+:flag:posting or transaction flag
+:number:posting or transaction's number
+*:payee:posting or transaction's payee
+*:account:posting's account
+*:postingDrCr:whether the posting is a debit or credit
+*:postingCmdty:posting's commodity
+*:postingQty:posting's quantity
+*:totalDrCr:whether the running total is a debit or credit
+*:totalCommodity:commodity of the running total
+*:totalQty:quantity of the running total
+:tags:posting's tags
+:memo:the posting and transaction memo
+:filename:filename where the posting came from
+.TE
+
+.TP
+.B --show-all
+Show all fields
+
+.TP
+.B --hide-all
+Hide all fields
+
+.TP
+.BI "--zero-balances " "show|hide"
+Whether to show the balance of all commodities in the
+.IR totalDrCr ", " totalCommodity ", and " totalQty
+fields, even if that balance is zero. (default: hide)
+
+.TP
+.B --help | -h
+Show help and exit
+
+.SH BALANCE REPORT
+The
+.B balance
+report summarizes the balances in each account that is represented in
+the postings that remain after the filtering specifications are
+carried out. You can use sorting specifications in the posting filter
+expression, but they will have no effect. The
+accounts are shown hierarchically.
+
+The
+.B balance
+report accepts the following options:
+
+.TP
+.BI "--zero-balances " "show|hide"
+Whether to show balances that are zero (default: hide)
+
+.TP
+.BI "--order " "ascending|descending"
+Sort in ascending (default) or descending order by account name
+
+.TP
+.B --help | -h
+Show help and exit
+
+.SH CONVERT REPORT
+
+The
+.B convert
+report shows account balances after converting all amounts to a single
+commodity. In addition to converting commodities, it also can sort
+accounts by their balances. Accepts ONLY the following report
+options:
+
+.TP
+.BI "--zero-balances " "show|hide"
+Whether to show balances that are zero (default: hide)
+
+.TP
+.BI "--commodity | -c " "TARGET-COMMODITY"
+Convert all commodities to
+.IR TARGET-COMMODITY .
+By default, the commodity that appears most often as the target
+commodity in your price data is used. If there is a tie, the price
+closest to the end of your list of prices is used.
+
+.TP
+.BI "--date | -d " "DATE-TIME"
+Convert prices as of the date and time given. By default, the current
+date and time is used.
+
+.TP
+.BI "--sort | -s " "name|qty"
+Sort balances by sub-account name (default) or by quantity
+
+.TP
+.BI "--order " "ascending|descending"
+Sort in ascending (default) or descending order
+
+.TP
+.B --help | -h
+Show help and exit
+
+.SH SERIALS
+
+Each posting is assigned several
+.IR serials ,
+each of which is a pair of ordinal numbers. The first number in the
+pair, or
+.IR "forward component" ,
+is assigned by numbering the transactions or postings from
+beginning to end beginning at zero, while the second number in the
+pair, or
+.IR "reverse component" ,
+is assigned by numbering the transactions or postings from end to
+beginning, beginning at zero. Here are all the serials that are
+assigned to each posting.
+
+.TP
+.B globalTransaction
+All transactions are numbered in order, beginning with those in the
+first file specified on the command line and ending with the last
+file. Occurs before the transactions are split into postings.
+
+.TP
+.B fileTransaction
+Like
+.IR globalTransaction ,
+but numbering restarts with each new file.
+
+.TP
+.B globalPosting
+All postings are numbered in order, beginning with those in the first
+file specified on the command line and ending with the last file.
+
+.TP
+.B filePosting
+Like
+.IR globalPosting ,
+but numbering restarts with each new file.
+
+.TP
+.B filtered
+Postings are numbered after first removing the postings as specified
+by the filtering options specified on the command line.
+
+.TP
+.B sorted
+Postings are numbered in order after the sorting options have been
+applied, which occurs after the filtering options have been applied.
+
+.TP
+.B visible
+Postings are numbered in order after removing the postings as
+specified by the options to the
+.I postings
+report. (Applies only to the
+.I postings
+report.)
+
+.SH DEFAULT OPTIONS
+This manual page often specifies defaults for various options. These
+are the defaults that come "out of the box." You may configure your
+own default options (see
+.BR penny-custom (7).)
+If you do that, the defaults you configure will be reflected in the
+output of
+.IR "penny -h" .
+
+.SH EXIT STATUS
+.B 0
+if no errors;
+.B 1
+if there was a problem.
+
+.SH BUGS
+Please report any bugs in the software or documentation to
+omari@smileystation.com.
+
+.SH SEE ALSO
+.BR penny-suite (7)
+
+The file
+.B examples/starter.pny
+in the tarball for the
+.B penny-bin
+package shows you how to write a ledger file.
diff --git a/doc/penny-fit-sample.hs b/doc/penny-fit-sample.hs
new file mode 100644
index 0000000..8cba3dc
--- /dev/null
+++ b/doc/penny-fit-sample.hs
@@ -0,0 +1,181 @@
+{-# OPTIONS_GHC -Wall #-}
+-- | This file is a sample of how to configure penny-fit. You will
+-- have to adapt it for your own needs. Rename the file to
+-- FILENAME.hs, where FILENAME is the name you want for your program
+-- (an easy choice is "penny-fit".) Then, compile the file with
+--
+-- ghc --make FILENAME
+--
+-- and if all goes well you will have a program to use.
+module Main where
+
+import Penny.Brenner
+import Data.Version
+
+-- | The Config type configures all the financial institution accounts.
+config :: Config
+config = Config
+ { defaultFitAcct = Nothing
+ -- ^ If you have a default financial institution account, use Just
+ -- ACCOUNT here. For example, if I wanted to use my amex account
+ -- by default, I would put @Just amex@ here. I don't want to use
+ -- an account by default; I want to be required to explicitly
+ -- state an account, so I put Nothing here.
+
+ , moreFitAccts = [ visa, checking, saving ]
+ -- ^ This is a list of financial institution accounts in addition
+ -- to the default (if you have one.)
+ }
+
+visa :: FitAcct
+visa = FitAcct
+ { fitAcctName = "visa"
+ -- ^ This is the name by which you will identify this account on
+ -- the command line (it will be case sensitive). You pick
+ -- financial institution accounts by using the @-f@ option.
+
+ , fitAcctDesc = unlines
+ [ "Main Visa card account."
+ , "To find the downloads, log in and then click on"
+ , "Statements --> Download --> Quicken."
+ ]
+ -- ^ A description of the financial institution account. This
+ -- appears when you use the @info@ command, so you can put
+ -- information in here like where to find the downloads on the
+ -- bank website.
+
+ , dbLocation = "/home/massysett/ledger/visa"
+ -- ^ The location of the database of financial institution
+ -- postings. You can make this path relative, in which case it is
+ -- interpreted relative to the current directory at runtime, or
+ -- absolute. No expansion of tildes, environment variables,
+ -- etc. is performed.
+
+ , pennyAcct = "Liabilities:Current:Amex"
+ -- ^ Postings from this financial institution appear under this
+ -- account in your ledger file(s).
+
+ , defaultAcct = "Expenses:Unclassified"
+ -- ^ When penny-fit finds a financial institution posting and it
+ -- does not have a matching posting in your ledger, it must create
+ -- a new transaction with two postings. One posting will be in the
+ -- pennyAcct specified above and the other posting will be in this
+ -- account.
+
+ , currency = "$"
+ -- ^ All postings will be in this currency
+
+ , qtySpec = S3a Period
+ -- ^ How to group digits when printing the resulting ledger.
+ --
+ -- Penny remembers the formatting of quantities entered in your
+ -- ledger. However, quantities imported from your bank statement
+ -- do not have formatting to remember, so you have to tell Penny
+ -- how to format them.
+ --
+ -- The default choice, S3a Period, formats quantities so that the
+ -- radix point is a period and so that there is no digit
+ -- grouping. Thus the amount 24435.80 will be rendered as
+ -- 24435.80
+ --
+ -- Other possible choices include:
+ --
+ -- S3b PGComma
+ -- formats quantities so the radix point is a period
+ -- and the grouping character is the comma, so 24435.80 renders as
+ -- 24,435.80
+ --
+ -- S3c CGSpace formats quantities so the radix point is a comma
+ -- and the grouping character is a space, so that 24435.80 renders
+ -- as 24 435,80 (in your ledger file, this will have to appear in
+ -- quotes as [24 435,80])
+
+ , translator = IncreaseIsCredit
+ -- ^ Postings from your financial institution are specified in
+ -- terms of increases or decreases. Postings in your ledger are
+ -- specified in terms of debits or credits. The translator
+ -- specifies how to convert a posting from your financial
+ -- institution to a posting in the pennyAcct in your ledger. For
+ -- deposit accounts (e.g. checking) you will typically use
+ -- IncreaseIsDebit; for liability accounts (e.g. credit cards) you
+ -- will typically use IncreaseIsCredit.
+
+ , side = CommodityOnLeft
+ -- ^ When penny-fit creates new postings it must put the commodity
+ -- either to the left of the quantity or to the right of the
+ -- quantity. Accordingly your choices here are CommodityOnLeft or
+ -- CommodityOnRight.
+
+ , spaceBetween = NoSpaceBetween
+ -- ^ When penny-fit creates new postings it must decide whether to
+ -- put a space between the commodity and the quantity. Accordingly
+ -- your choices here are SpaceBetween or NoSpaceBetween.
+
+ , parser = ofxParser
+ -- ^ This determines how to parse the data you have
+ -- downloaded. Currently there is only one parser, which handles
+ -- OFX data. Many financial institutions provide OFX data so this
+ -- will get you a long way. If you want to write additional
+ -- parsers you can provide your own function of this type (perhaps
+ -- your bank only provides CSV files, for example.)
+
+ , toLincolnPayee = usePayeeOrDesc
+ -- ^ Sometimes the financial institution provides Payee information,
+ -- sometimes it does not. Sometimes the Desc might have additional
+ -- information that you might want to remove. This function can be
+ -- used to do that. The resulting Lincoln Payee is used for any
+ -- transactions that are created by the merge command. The resulting
+ -- payee is also used when comparing new financial institution
+ -- postings to already existing ledger transactions in order to
+ -- guess at which payee and accounts to create in the transactions
+ -- created by the merge command.
+ --
+ -- 'usePayeeOrDesc' simply uses the payee if it is available;
+ -- otherwise, it uses the description. (Many banks provide
+ -- descriptions only and do not provide separate payee information.)
+ }
+
+checking :: FitAcct
+checking = FitAcct
+ { fitAcctName = "checking"
+ , fitAcctDesc = "Main checking account."
+ , dbLocation = "/home/massysett/ledger/checking"
+ , pennyAcct = "Assets:Current:Checking"
+ , defaultAcct = "Expenses:Unclassified"
+ , currency = "$"
+ , qtySpec = S3a Period
+ , translator = IncreaseIsDebit
+ , side = CommodityOnLeft
+ , spaceBetween = NoSpaceBetween
+ , toLincolnPayee = usePayeeOrDesc
+ , parser = ofxParser
+ }
+
+saving :: FitAcct
+saving = FitAcct
+ { fitAcctName = "saving"
+ , fitAcctDesc = "Main saving account."
+ , dbLocation = "/home/massysett/ledger/saving"
+ , pennyAcct = "Assets:Current:Checking:Omari"
+ , defaultAcct = "Expenses:Unclassified"
+ , currency = "$"
+ , qtySpec = S3a Period
+ , translator = IncreaseIsDebit
+ , side = CommodityOnLeft
+ , spaceBetween = NoSpaceBetween
+ , toLincolnPayee = usePayeeOrDesc
+ , parser = ofxParser
+ }
+
+-- Leave things below this line alone (unless you know what you're
+-- doing of course.)
+
+-- brennerMain requires that you supply a version. You can edit this
+-- as you see fit, or use the version that Cabal supplies.
+version :: Version
+version = Version [1] []
+
+-- | Always leave these two lines the same (unless you know what you
+-- are doing of course).
+main :: IO ()
+main = brennerMain version config
diff --git a/install-docs b/install-docs
new file mode 100755
index 0000000..453ddac
--- /dev/null
+++ b/install-docs
@@ -0,0 +1,59 @@
+#!/bin/sh
+
+# install-docs installs documentation for penny. You can edit the
+# PREFIX variable below. Man pages go to
+# $PREFIX/share/man/man[0-9]. Other documentation goes to
+# $PREFIX/share/doc/penny.
+
+# To remove the documentation, run "sh install-docs remove."
+
+PREFIX=/usr/local
+MANDIR=$PREFIX/share/man
+DOCDIR=$PREFIX/share/doc/penny
+
+doInstall() {
+ for suffix in 1 7; do
+ install -m755 -d $MANDIR/man${suffix}
+ for filename in doc/man/*.${suffix}; do
+ install -v -m644 $filename $MANDIR/man${suffix}
+ done
+ done
+
+ install -m755 -d $DOCDIR
+ for filename in doc/*.org doc/*.dot doc/*.hs; do
+ install -v -m644 $filename $DOCDIR
+ done
+
+ install -m755 -d $DOCDIR/examples
+ for filename in doc/examples/*; do
+ install -v -m644 $filename $DOCDIR/examples
+ done
+}
+
+remove() {
+ for suffix in 1 7; do
+ for filename in man/*.${suffix}; do
+ rm -v $MANDIR/man${suffix}/"$(basename $filename)"
+ done
+ rmdir -v -p $MANDIR/man${suffix}
+ done
+ rmdir -v -p $MANDIR
+
+ for filename in doc/*.org doc/*.dot doc/*.hs; do
+ rm -v $DOCDIR/"$(basename $filename)"
+ done
+ rmdir -v -p $DOCDIR
+
+ for filename in doc/examples/*; do
+ rm -v $DOCDIR/examples/"$(basename $filename)"
+ done
+ rmdir -v -p $DOCDIR/examples
+
+}
+
+
+if [ x$1 = xremove ]; then
+ remove
+else
+ doInstall
+fi
diff --git a/lib/Penny.hs b/lib/Penny.hs
new file mode 100644
index 0000000..b86d2a1
--- /dev/null
+++ b/lib/Penny.hs
@@ -0,0 +1,569 @@
+-- | Penny - extensible double-entry accounting system
+
+module Penny
+ ( -- * Building a custom Penny binary
+
+ -- | Everything you need to create a custom Penny program is
+ -- available by importing only this module.
+ Version(..)
+ , Defaults(..)
+ , Z.Matcher(..)
+
+ -- ** Color schemes
+ , E.Scheme(..)
+ , E.Changers
+ , E.Labels(..)
+ , E.EvenAndOdd(..)
+ , module System.Console.Rainbow
+
+ -- ** Sorting
+ , Z.SortField(..)
+ , CabP.SortOrder(..)
+
+ -- ** Expression type
+ , Exp.ExprDesc(..)
+
+ -- ** Convert report options
+ , Target(..)
+ , CP.SortBy(..)
+
+ -- ** Postings report options
+ , Fields(..)
+ , Spacers(..)
+ , widthFromRuntime
+ , Ps.yearMonthDay
+
+ -- ** Formatting quantities
+ , S3(..)
+ , FormatQty
+ , qtyFormatter
+ , getQtyFormat
+ , L.Radix(..)
+ , L.PeriodGrp(..)
+ , L.CommaGrp(..)
+
+ -- ** Runtime
+ , S.Runtime
+ , S.environment
+
+ -- ** Text
+ , X.Text
+ , X.pack
+
+ -- ** Main function
+ , runPenny
+
+ -- * Developer overview
+
+ -- | Penny is organized into a tree of modules, each with a
+ -- name. Check out the links for details on each component of
+ -- Penny.
+ --
+ -- "Penny.Brenner" - Penny financial institution transaction
+ -- handling. Depends on Lincoln and Copper.
+ --
+ -- "Penny.Cabin" - Penny reports. Depends on Lincoln and Liberty.
+ --
+ -- "Penny.Copper" - the Penny parser. Depends on Lincoln.
+ --
+ -- "Penny.Liberty" - Penny command line parser helpers. Depends on
+ -- Lincoln and Copper.
+ --
+ -- "Penny.Lincoln" - the Penny core. Depends on no other Penny
+ -- components.
+ --
+ -- "Penny.Shield" - the Penny runtime environment. Depends on
+ -- Lincoln.
+ --
+ -- "Penny.Steel" - independent utilities. Depends on no other
+ -- Penny components.
+ --
+ -- "Penny.Wheat" - tools to use with
+ -- "Penny.Steel.Prednote". Depends on Steel, Lincoln, and Copper.
+ --
+ -- "Penny.Zinc" - the Penny command-line interface. Depends on
+ -- Cabin, Copper, Liberty, and Lincoln.
+ --
+ -- The dependencies are represented as a dot file in
+ -- bin/doc/dependencies.dot in the Penny git repository.
+ ) where
+
+import Data.Ord (comparing)
+import Data.List (sortBy, groupBy)
+import Data.Maybe (mapMaybe, fromMaybe)
+import qualified Data.Text as X
+import qualified Data.Map as Map
+import Data.Version (Version(..))
+import qualified Penny.Cabin.Balance.Convert as Conv
+import qualified Penny.Cabin.Balance.Convert.Parser as CP
+import qualified Penny.Cabin.Balance.Convert.Options as ConvOpts
+import qualified Penny.Cabin.Balance.MultiCommodity as MC
+import qualified Penny.Cabin.Balance.MultiCommodity.Parser as MP
+import System.Console.Rainbow
+import qualified Penny.Cabin.Interface as I
+import qualified Penny.Cabin.Options as CO
+import qualified Penny.Cabin.Parsers as CabP
+import qualified Penny.Cabin.Posts as Ps
+import qualified Penny.Cabin.Posts.Fields as PF
+import qualified Penny.Cabin.Posts.Spacers as PS
+import qualified Penny.Cabin.Posts.Meta as M
+import qualified Penny.Cabin.Scheme as E
+import qualified Penny.Copper as Cop
+import Penny.Steel.Sums
+import qualified Penny.Steel.Sums as Su
+import qualified Penny.Lincoln as L
+import qualified Data.Prednote.Expressions as Exp
+import qualified Penny.Zinc as Z
+import qualified Penny.Shield as S
+import qualified Text.Matchers as Mr
+
+-- | A function used to format quantities.
+type FormatQty
+ = [Cop.LedgerItem]
+ -- ^ All parsed items
+
+ -> L.Amount L.Qty
+ -> X.Text
+
+-- | This type contains settings for all the reports, as well as
+-- default settings for the global options. Some of these can be
+-- overridden on the command line.
+data Defaults = Defaults
+ { caseSensitive :: Bool
+ -- ^ Whether the matcher is case sensitive by default
+
+ , matcher :: Z.Matcher
+ -- ^ Which matcher to use
+
+ , colorToFile :: Bool
+ -- ^ Use colors when standard output is not a terminal?
+
+ , expressionType :: Exp.ExprDesc
+ -- ^ Use RPN or infix expressions? This affects both the posting
+ -- filter and the filter for the Postings report.
+
+ , defaultScheme :: Maybe E.Scheme
+ -- ^ Default color scheme. If Nothing, there is no default color
+ -- scheme. If there is no default color scheme and the user does
+ -- not pick one on the command line, no colors will be used.
+
+ , additionalSchemes :: [E.Scheme]
+ -- ^ Additional color schemes the user can pick from on the
+ -- command line.
+
+ , sorter :: [(Z.SortField, CabP.SortOrder)]
+ -- ^ Postings are sorted in this order by default. For example, if
+ -- the first pair is (Date, Ascending), then postings are first
+ -- sorted by date in ascending order. If the second pair is
+ -- (Payee, Ascending), then postings with the same date are then
+ -- sorted by payee.
+ --
+ -- If this list is empty, then by default postings are left in the
+ -- same order as they appear in the ledger files.
+
+ , formatQty :: FormatQty
+ -- ^ How to format quantities. This affects only quantities that
+ -- are not parsed from the ledger. Examples include calculated
+ -- totals and inferred quantities. Affects all reports.
+
+ , balanceShowZeroBalances :: Bool
+ -- ^ Show zero balances in the balance report? If True, show them;
+ -- if False, hide them.
+
+ , balanceOrder :: CabP.SortOrder
+ -- ^ Whether to sort the accounts in ascending or descending order
+ -- by account name in the balance report.
+
+ , convertShowZeroBalances :: Bool
+ -- ^ Show zero balances in the convert report? If True, show them;
+ -- if False, hide them.
+
+ , convertTarget :: Target
+ -- ^ The commodity to which to convert the commodities in the
+ -- convert report.
+
+ , convertOrder :: CabP.SortOrder
+ -- ^ Sort the convert report in ascending or descending order.
+
+ , convertSortBy :: CP.SortBy
+ -- ^ Sort by account or by quantity in the convert report.
+
+ , postingsFields :: Fields Bool
+ -- ^ Fields to show by default in the postings report.
+
+ , postingsWidth :: Int
+ -- ^ The postings report is roughly this wide by
+ -- default. Typically this will be as wide as your terminal.
+
+ , postingsShowZeroBalances :: Bool
+ -- ^ Show zero balances in the postings report? If True, show
+ -- them; if False, hide them.
+
+ , postingsDateFormat :: (M.PostMeta, L.Posting) -> X.Text
+ -- ^ How to format dates in the postings report.
+
+ , postingsSubAccountLength :: Int
+ -- ^ Account names in the postings report are shortened if
+ -- necessary in order to help the report fit within the allotted
+ -- width (see postingsWidth). Account names are only shortened as
+ -- much as is necessary for them to fit; however, each sub-account
+ -- name will not be shortened any more than the amount given here.
+
+ , postingsPayeeAllocation :: Int
+ -- ^ postingsPayeeAllocation and postingsAccountAllocation
+ -- determine how much space is allotted to the payee and account
+ -- fields in the postings report. These fields are variable
+ -- width. After space for most other fields is allotted, space is
+ -- allotted for these two fields. The two fields divide the space
+ -- proportionally depending on postingsPayeeAllocation and
+ -- postingsAccountAllocation. For example, if
+ -- postingsPayeeAllocation is 60 and postingsAccountAllocation is
+ -- 40, then the payee field gets 60 percent of the leftover space
+ -- and the account field gets 40 percent of the leftover space.
+ --
+ -- Both postingsPayeeAllocation and postingsAccountAllocation
+ -- must be positive integers; if either one is less than 1, your
+ -- program will crash at runtime.
+
+ , postingsAccountAllocation :: Int
+ -- ^ See postingsPayeeAllocation above for an explanation
+
+ , postingsSpacers :: Spacers Int
+ -- ^ Determines the number of spaces that appears to the right of
+ -- each named field; for example, sPayee indicates how many spaces
+ -- will appear to the right of the payee field. Each field of the
+ -- Spacers should be a non-negative integer (although currently
+ -- the absolute value of the field is taken.)
+ }
+
+-- | Provides a function to use in the 'formatQty' field. This formats
+-- quantities that were not parsed in the ledger. It first consults a
+-- list of all items that were parsed from the ledger. It examines
+-- these items to determine if another item with the same commodity
+-- already exists in the ledger.
+--
+-- If other items with the same commodity exist in the ledger, the
+-- radix point most frequently occurring amongst those items is
+-- used. If at least one of these items (with this radix point) also
+-- has grouped digits, then the quantity will be formatted with
+-- grouped digits; otherwise, no digit grouping is performed. If digit
+-- grouping is performed, it is done according to the following rules:
+--
+-- * only digits to the left of the radix point are grouped
+--
+-- * grouping is performed only if the number has at least five
+-- digits. Therefore, 1234 is not grouped, but 1,234.5 is grouped, as
+-- is 12,345
+--
+-- * the character most frequently appearing as a grouping character
+-- (for this particular commodity and radix point) is used to perform
+-- grouping
+--
+-- * digits are grouped into groups of 3 digits
+--
+-- If a radix point cannot be determined from the quantities for a
+-- given commodity, then the radix point appearing most frequently for
+-- all commodities is used. If it's impossible to determine a radix
+-- point from all commodities, then the given default radix point and
+-- digit grouping (if desired) is used.
+--
+-- This function builds a map internally which holds all the
+-- formatting information; it might be expensive to build, so the
+-- function is written to be partially applied.
+
+qtyFormatter
+ :: Su.S3 L.Radix L.PeriodGrp L.CommaGrp
+ -- ^ What to do if no radix or grouping information can be
+ -- determined from the ledger. Pass Radix if you want to use a
+ -- radix point but no grouping; a PeriodGrp if you want to use a
+ -- period for a radix point and the given grouping character, or a
+ -- CommaGrp if you want to use a comma for a radix point and the
+ -- given grouping character.
+
+ -> FormatQty
+qtyFormatter df ls =
+ let getFmt = getQtyFormat df ls
+ in \a -> L.showQtyRep . L.qtyToRep (getFmt a) . L.qty $ a
+
+-- | Obtains radix and grouping information for a particular commodity
+-- and quantity, but does not actually perform the formatting.
+getQtyFormat
+ :: Su.S3 L.Radix L.PeriodGrp L.CommaGrp
+ -- ^ What to do if no radix or grouping information can be
+ -- determined from the ledger. Pass Radix if you want to use a
+ -- radix point but no grouping; a PeriodGrp if you want to use a
+ -- period for a radix point and the given grouping character, or a
+ -- CommaGrp if you want to use a comma for a radix point and the
+ -- given grouping character.
+
+ -> [Cop.LedgerItem]
+ -> L.Amount L.Qty
+ -> Su.S3 L.Radix L.PeriodGrp L.CommaGrp
+getQtyFormat df ls =
+ let m = formattingMap ls
+ in \a -> fromMaybe df (Map.lookup (L.commodity a) m)
+
+
+-- | Returns a map of each commodity in the ledger and the grouping to
+-- use for it.
+formattingMap
+ :: [Cop.LedgerItem]
+ -> Map.Map L.Commodity (Su.S3 L.Radix L.PeriodGrp L.CommaGrp)
+formattingMap
+ = Map.fromList
+ . mapMaybe formatCmdty
+ . groupBy (\x y -> fst x == fst y)
+ . sortBy (comparing fst)
+ . allQtyRep
+
+-- | Given a list of (Commodity, QtyRep) pairs, get a single pair of
+-- the commodity and the grouping that should be used for this
+-- commodity. The input list must not be empty. Returns Nothing if no
+-- group data can be ascertained.
+formatCmdty
+ :: [(L.Commodity, L.QtyRep)]
+ -> Maybe (L.Commodity, Su.S3 L.Radix L.PeriodGrp L.CommaGrp)
+formatCmdty ls = case L.bestRadGroup . map snd $ ls of
+ Nothing -> Nothing
+ Just r -> Just (fst . head $ ls, r)
+
+-- | Given a list of LedgerItem, create a list of pairs of commodities
+-- and QtyRep.
+allQtyRep :: [Cop.LedgerItem] -> [(L.Commodity, L.QtyRep)]
+allQtyRep = concatMap toPairs
+ where
+ toPairs i = case i of
+ Su.S4a t ->
+ mapMaybe toEntPair
+ . L.unEnts
+ . snd
+ . L.unTransaction
+ $ t
+ Su.S4b p ->
+ [( L.unTo . L.to . L.price $ p
+ , L.unCountPerUnit . L.countPerUnit . L.price $ p)]
+ _ -> []
+
+toEntPair :: L.Ent m -> Maybe (L.Commodity, L.QtyRep)
+toEntPair e = case L.entry e of
+ Left en -> Just (L.commodity . L.amount $ en, L.qty . L.amount $ en)
+ Right _ -> Nothing
+
+-- | Creates an IO action that you can use for the main function.
+runPenny
+ :: Version
+ -- ^ Version of the executable
+ -> (S.Runtime -> Defaults)
+ -- ^ runPenny will apply this function to the Runtime. This way
+ -- the defaults you use can vary depending on environment
+ -- variables, the terminal type, the date, etc.
+ -> IO ()
+runPenny ver getDefaults = do
+ rt <- S.runtime
+ let df = getDefaults rt
+ rs = allReports df
+ Z.runZinc ver (toZincDefaults df) rt rs
+
+-- | The commodity to which to convert the commodities in the convert
+-- report.
+data Target
+ = AutoTarget
+ -- ^ Selects a target commodity automatically, based on which
+ -- commodity is the most common target commodity in the prices in
+ -- your ledger files. If there is a tie for most common target
+ -- commodity, the target that appears later in your ledger files
+ -- is used.
+ | ManualTarget String
+ -- ^ Always uses the commodity named by the string given.
+ deriving Show
+
+-- | Gets the current screen width from the runtime. If the COLUMNS
+-- environment variable is not set, uses 80.
+widthFromRuntime :: S.Runtime -> Int
+widthFromRuntime rt = case S.screenWidth rt of
+ Nothing -> 80
+ Just sw -> S.unScreenWidth sw
+
+convTarget :: Target -> CP.Target
+convTarget t = case t of
+ AutoTarget -> CP.AutoTarget
+ ManualTarget s -> CP.ManualTarget . L.To . L.Commodity . X.pack $ s
+
+allReports
+ :: Defaults
+ -> [I.Report]
+allReports df =
+ let bd = toBalanceDefaults df
+ cd = toConvertDefaults df
+ pd = toPostingsDefaults df
+ in [ Ps.zincReport pd
+ , MC.parseReport bd
+ , Conv.cmdLineReport cd
+ ]
+
+toZincDefaults :: Defaults -> Z.Defaults
+toZincDefaults d = Z.Defaults
+ { Z.sensitive =
+ if caseSensitive d then Mr.Sensitive else Mr.Insensitive
+ , Z.matcher = matcher d
+ , Z.colorToFile = Z.ColorToFile . colorToFile $ d
+ , Z.defaultScheme = defaultScheme d
+ , Z.moreSchemes = additionalSchemes d
+ , Z.sorter = sorter d
+ , Z.exprDesc = expressionType d
+ , Z.formatQty = formatQty d
+ }
+
+toBalanceDefaults :: Defaults -> MP.ParseOpts
+toBalanceDefaults d = MP.ParseOpts
+ { MP.showZeroBalances =
+ CO.ShowZeroBalances . balanceShowZeroBalances $ d
+ , MP.order = balanceOrder d
+ }
+
+toConvertDefaults :: Defaults -> ConvOpts.DefaultOpts
+toConvertDefaults d = ConvOpts.DefaultOpts
+ { ConvOpts.showZeroBalances =
+ CO.ShowZeroBalances . convertShowZeroBalances $ d
+ , ConvOpts.target = convTarget . convertTarget $ d
+ , ConvOpts.sortOrder = convertOrder d
+ , ConvOpts.sortBy = convertSortBy d
+ }
+
+toPostingsDefaults :: Defaults -> Ps.ZincOpts
+toPostingsDefaults d = Ps.ZincOpts
+ { Ps.fields = convFields . postingsFields $ d
+ , Ps.width = Ps.ReportWidth . postingsWidth $ d
+ , Ps.showZeroBalances =
+ CO.ShowZeroBalances . postingsShowZeroBalances $ d
+ , Ps.dateFormat = postingsDateFormat d
+ , Ps.subAccountLength =
+ Ps.SubAccountLength . postingsSubAccountLength $ d
+ , Ps.payeeAllocation =
+ Ps.alloc . postingsPayeeAllocation $ d
+ , Ps.accountAllocation =
+ Ps.alloc . postingsAccountAllocation $ d
+ , Ps.spacers = convSpacers . postingsSpacers $ d
+ }
+
+data Spacers a = Spacers
+ { sGlobalTransaction :: a
+ , sRevGlobalTransaction :: a
+ , sGlobalPosting :: a
+ , sRevGlobalPosting :: a
+ , sFileTransaction :: a
+ , sRevFileTransaction :: a
+ , sFilePosting :: a
+ , sRevFilePosting :: a
+ , sFiltered :: a
+ , sRevFiltered :: a
+ , sSorted :: a
+ , sRevSorted :: a
+ , sVisible :: a
+ , sRevVisible :: a
+ , sLineNum :: a
+ , sDate :: a
+ , sFlag :: a
+ , sNumber :: a
+ , sPayee :: a
+ , sAccount :: a
+ , sPostingDrCr :: a
+ , sPostingCmdty :: a
+ , sPostingQty :: a
+ , sTotalDrCr :: a
+ , sTotalCmdty :: a
+ } deriving (Show, Eq)
+
+data Fields a = Fields
+ { fGlobalTransaction :: a
+ , fRevGlobalTransaction :: a
+ , fGlobalPosting :: a
+ , fRevGlobalPosting :: a
+ , fFileTransaction :: a
+ , fRevFileTransaction :: a
+ , fFilePosting :: a
+ , fRevFilePosting :: a
+ , fFiltered :: a
+ , fRevFiltered :: a
+ , fSorted :: a
+ , fRevSorted :: a
+ , fVisible :: a
+ , fRevVisible :: a
+ , fLineNum :: a
+ , fDate :: a
+ , fFlag :: a
+ , fNumber :: a
+ , fPayee :: a
+ , fAccount :: a
+ , fPostingDrCr :: a
+ , fPostingCmdty :: a
+ , fPostingQty :: a
+ , fTotalDrCr :: a
+ , fTotalCmdty :: a
+ , fTotalQty :: a
+ , fTags :: a
+ , fMemo :: a
+ , fFilename :: a
+ } deriving (Show, Eq)
+
+convSpacers :: Spacers a -> PS.Spacers a
+convSpacers s = PS.Spacers
+ { PS.globalTransaction = sGlobalTransaction s
+ , PS.revGlobalTransaction = sRevGlobalTransaction s
+ , PS.globalPosting = sGlobalPosting s
+ , PS.revGlobalPosting = sRevGlobalPosting s
+ , PS.fileTransaction = sFileTransaction s
+ , PS.revFileTransaction = sRevFileTransaction s
+ , PS.filePosting = sFilePosting s
+ , PS.revFilePosting = sRevFilePosting s
+ , PS.filtered = sFiltered s
+ , PS.revFiltered = sRevFiltered s
+ , PS.sorted = sSorted s
+ , PS.revSorted = sRevSorted s
+ , PS.visible = sVisible s
+ , PS.revVisible = sRevVisible s
+ , PS.lineNum = sLineNum s
+ , PS.date = sDate s
+ , PS.flag = sFlag s
+ , PS.number = sNumber s
+ , PS.payee = sPayee s
+ , PS.account = sAccount s
+ , PS.postingDrCr = sPostingDrCr s
+ , PS.postingCmdty = sPostingCmdty s
+ , PS.postingQty = sPostingQty s
+ , PS.totalDrCr = sTotalDrCr s
+ , PS.totalCmdty = sTotalCmdty s
+ }
+
+convFields :: Fields a -> PF.Fields a
+convFields f = PF.Fields
+ { PF.globalTransaction = fGlobalTransaction f
+ , PF.revGlobalTransaction = fRevGlobalTransaction f
+ , PF.globalPosting = fGlobalPosting f
+ , PF.revGlobalPosting = fRevGlobalPosting f
+ , PF.fileTransaction = fFileTransaction f
+ , PF.revFileTransaction = fRevFileTransaction f
+ , PF.filePosting = fFilePosting f
+ , PF.revFilePosting = fRevFilePosting f
+ , PF.filtered = fFiltered f
+ , PF.revFiltered = fRevFiltered f
+ , PF.sorted = fSorted f
+ , PF.revSorted = fRevSorted f
+ , PF.visible = fVisible f
+ , PF.revVisible = fRevVisible f
+ , PF.lineNum = fLineNum f
+ , PF.date = fDate f
+ , PF.flag = fFlag f
+ , PF.number = fNumber f
+ , PF.payee = fPayee f
+ , PF.account = fAccount f
+ , PF.postingDrCr = fPostingDrCr f
+ , PF.postingCmdty = fPostingCmdty f
+ , PF.postingQty = fPostingQty f
+ , PF.totalDrCr = fTotalDrCr f
+ , PF.totalCmdty = fTotalCmdty f
+ , PF.totalQty = fTotalQty f
+ , PF.tags = fTags f
+ , PF.memo = fMemo f
+ , PF.filename = fFilename f
+ }
diff --git a/lib/Penny/Brenner.hs b/lib/Penny/Brenner.hs
new file mode 100644
index 0000000..0dc61fe
--- /dev/null
+++ b/lib/Penny/Brenner.hs
@@ -0,0 +1,255 @@
+-- | Brenner - Penny financial institution interfaces
+--
+-- Brenner provides a uniform way to interact with downloaded data
+-- from financial Given a parser, Brenner will import the transactions
+-- and store them in a database. From there it is easy to merge the
+-- transactions (without duplicates) into a ledger file, and then to
+-- clear transactions from statements in an automated fashion.
+module Penny.Brenner
+ ( FitAcct(..)
+ , Config(..)
+ , Su.S3(..)
+ , L.Radix(..)
+ , L.PeriodGrp(..)
+ , L.CommaGrp(..)
+ , Y.Translator(..)
+ , L.Side(..)
+ , L.SpaceBetween(..)
+ , usePayeeOrDesc
+ , brennerMain
+ , ofxParser
+ ) where
+
+import qualified Penny.Brenner.Types as Y
+import qualified Data.Text as X
+import qualified Data.Version as V
+import qualified Penny.Liberty as Ly
+import qualified Penny.Lincoln as L
+import qualified Penny.Lincoln.Builders as Bd
+import qualified Penny.Brenner.Clear as C
+import qualified Penny.Brenner.Database as D
+import qualified Penny.Brenner.Import as I
+import qualified Penny.Brenner.Info as Info
+import qualified Penny.Brenner.Merge as M
+import qualified Penny.Brenner.OFX as O
+import qualified Penny.Brenner.Print as P
+import qualified Penny.Steel.Sums as Su
+import qualified System.Console.MultiArg as MA
+import System.Environment (getProgName)
+import qualified System.Exit as Exit
+import qualified Control.Monad.Exception.Synchronous as Ex
+
+-- | Brenner, with a pre-compiled configuration.
+brennerMain
+ :: V.Version
+ -- ^ Binary version
+ -> Config
+ -> IO ()
+brennerMain v cf = do
+ let cf' = convertConfig cf
+ pn <- getProgName
+ ei <- MA.modesIO (globalOpts v) (preProcessor cf')
+ case ei of
+ Left showHelp -> putStr (showHelp pn) >> Exit.exitSuccess
+ Right g -> g
+
+type GetHelp = MA.ProgName -> String
+
+-- | Parses global options for a pre-compiled configuration.
+globalOpts
+ :: V.Version
+ -- ^ Binary version
+ -> MA.Opts GetHelp Y.FitAcctName
+globalOpts v = MA.optsHelpVersion help (Ly.version v)
+ [ MA.OptSpec ["fit-account"] "f"
+ (MA.OneArg (Y.FitAcctName . X.pack))
+ ]
+
+-- | Pre-processes global options for a pre-compiled configuration.
+preProcessor
+ :: Y.Config
+ -> [Y.FitAcctName]
+ -> Ex.Exceptional String
+ (Either (IO ())
+ [MA.Mode (MA.ProgName -> String) (IO ())])
+preProcessor cf args = do
+ mayFi <- case args of
+ [] -> return $ Y.defaultFitAcct cf
+ _ ->
+ let pdct a = Y.fitAcctName a == s
+ s = last args
+ toFilter = case Y.defaultFitAcct cf of
+ Nothing -> Y.moreFitAccts cf
+ Just d -> d : Y.moreFitAccts cf
+ in case filter pdct toFilter of
+ [] -> Ex.throw $
+ "financial institution account "
+ ++ (X.unpack . Y.unFitAcctName $ s) ++ " not configured."
+ c:[] -> return $ Just c
+ _ -> Ex.throw $
+ "more than one financial institution account "
+ ++ "named " ++ (X.unpack . Y.unFitAcctName $ s)
+ ++ " configured."
+ return . Right $ allModes cf mayFi
+
+-- | Each mode takes a Maybe FitAcct. Even if every mode needs a
+-- FitAcct to function, they take a Maybe FitAcct because otherwise
+-- the user will not even get online help if a FitAcct is not
+-- supplied. Each mode must fail on its own if it actually needs a
+-- FitAcct.
+
+allModes
+ :: Y.Config
+ -> Maybe Y.FitAcct
+ -> [MA.Mode (MA.ProgName -> String) (IO ())]
+allModes c a =
+ [ C.mode a
+ , I.mode a
+ , Info.mode c
+ , M.mode a
+ , P.mode a
+ , D.mode a ]
+
+-- | Help for a pre-compiled configuration.
+help
+ :: String
+ -- ^ Program name
+
+ -> String
+help n = unlines ls
+ where
+ ls = [ "usage: " ++ n ++ " [global-options]"
+ ++ " COMMAND [local-options]"
+ ++ " ARGS..."
+ , ""
+ , "where COMMAND is one of:"
+ , "import, merge, clear, database, print, info"
+ , ""
+ , "For help on an individual command and its"
+ ++ " local options, use "
+ , n ++ " COMMAND --help"
+ , ""
+ , "Global Options:"
+ , "-f, --fit-account ACCOUNT"
+ , " use the given financial institution account"
+ , " (use the \"info\" command to see which are available)."
+ , " If this option does not appear,"
+ , " the default account is used if there is one."
+ ]
+
+-- | Information to configure a single financial institution account.
+data FitAcct = FitAcct
+ { fitAcctName :: String
+ -- ^ Name for this financial institution account, e.g. @House
+ -- Checking@ or @Megabank@.
+
+ , fitAcctDesc :: String
+ -- ^ Additional information about this financial institution
+ -- account. Here I put information on where to find the statments
+ -- for download on the website.
+
+ , dbLocation :: String
+ -- ^ Path and filename to where the database is kept. You can use
+ -- an absolute or relative path (if it is relative, it will be
+ -- resolved relative to the current directory at runtime.)
+
+ , pennyAcct :: String
+ -- ^ The account that you use in your Penny file to hold
+ -- transactions for this card. Separate each sub-account with
+ -- colons (as you do in the Penny file.)
+
+ , defaultAcct :: String
+ -- ^ When new transactions are created, one of the postings will
+ -- be in the amexAcct given above. The other posting will be in
+ -- this account.
+
+ , currency :: String
+ -- ^ The commodity for the currency of your card (e.g. @$@).
+
+ , qtySpec :: Su.S3 L.Radix L.PeriodGrp L.CommaGrp
+ -- ^ How to group digits when printing the resulting ledger.
+ --
+ -- Penny remembers the formatting of quantities entered in your
+ -- ledger. However, quantities imported from your bank statement
+ -- do not have formatting to remember, so you have to tell Penny
+ -- how to format them.
+
+ , translator :: Y.Translator
+ -- ^ See the documentation under the 'Translator' type for
+ -- details.
+
+ , side :: L.Side
+ -- ^ When creating new transactions, the commodity will be on this
+ -- side
+
+ , spaceBetween :: L.SpaceBetween
+ -- ^ When creating new transactions, is there a space between the
+ -- commodity and the quantity
+
+ , parser :: ( Y.ParserDesc
+ , Y.FitFileLocation -> IO (Ex.Exceptional String [Y.Posting]))
+ -- ^ Parses a file of transactions from the financial
+ -- institution. The function must open the file and parse it. This
+ -- is in the IO monad not only because the function must open the
+ -- file itself, but also so the function can perform arbitrary IO
+ -- (run pdftotext, maybe?) If there is failure, the function can
+ -- return an Exceptional String, which is the error
+ -- message. Alternatively the function can raise an exception in the
+ -- IO monad (currently Brenner makes no attempt to catch these) so
+ -- if any of the IO functions throw you can simply not handle the
+ -- exceptions.
+ --
+ -- The first element of the pair is a help string which should
+ -- indicate how to download the data, as a helpful reminder.
+
+ , toLincolnPayee :: Y.Desc -> Y.Payee -> L.Payee
+ -- ^ Sometimes the financial institution provides Payee information,
+ -- sometimes it does not. Sometimes the Desc might have additional
+ -- information that you might want to remove. This function can be
+ -- used to do that. The resulting Lincoln Payee is used for any
+ -- transactions that are created by the merge command. The resulting
+ -- payee is also used when comparing new financial institution
+ -- postings to already existing ledger transactions in order to
+ -- guess at which payee and accounts to create in the transactions
+ -- created by the merge command.
+
+
+ } deriving Show
+
+convertFitAcct :: FitAcct -> Y.FitAcct
+convertFitAcct (FitAcct fn fd db ax df cy gs tl sd sb ps tlp) = Y.FitAcct
+ { Y.fitAcctName = Y.FitAcctName . X.pack $ fn
+ , Y.fitAcctDesc = Y.FitAcctDesc . X.pack $ fd
+ , Y.dbLocation = Y.DbLocation . X.pack $ db
+ , Y.pennyAcct = Y.PennyAcct . Bd.account . X.pack $ ax
+ , Y.defaultAcct = Y.DefaultAcct . Bd.account . X.pack $ df
+ , Y.currency = Y.Currency . L.Commodity . X.pack $ cy
+ , Y.qtySpec = gs
+ , Y.translator = tl
+ , Y.side = sd
+ , Y.spaceBetween = sb
+ , Y.parser = ps
+ , Y.toLincolnPayee = tlp
+ }
+
+data Config = Config
+ { defaultFitAcct :: Maybe FitAcct
+ , moreFitAccts :: [FitAcct]
+ } deriving Show
+
+convertConfig :: Config -> Y.Config
+convertConfig (Config d m) = Y.Config
+ { Y.defaultFitAcct = fmap convertFitAcct d
+ , Y.moreFitAccts = map convertFitAcct m
+ }
+
+-- | A simple function to use for 'toLincolnPayee'. Uses the financial
+-- institution payee if it is available; otherwise, uses the financial
+-- institution description.
+usePayeeOrDesc :: Y.Desc -> Y.Payee -> L.Payee
+usePayeeOrDesc (Y.Desc d) (Y.Payee p) = L.Payee $
+ if X.null p then d else p
+
+-- | Parser for OFX data.
+ofxParser :: (Y.ParserDesc, Y.ParserFn)
+ofxParser = O.parser
diff --git a/lib/Penny/Brenner/Clear.hs b/lib/Penny/Brenner/Clear.hs
new file mode 100644
index 0000000..dce4acf
--- /dev/null
+++ b/lib/Penny/Brenner/Clear.hs
@@ -0,0 +1,185 @@
+module Penny.Brenner.Clear (mode) where
+
+import Control.Applicative
+import qualified Control.Monad.Exception.Synchronous as Ex
+import Control.Monad (guard, mzero, when)
+import Data.Maybe (mapMaybe, fromMaybe)
+import Data.Monoid (mconcat, First(..))
+import qualified Data.Set as Set
+import qualified Data.Map as M
+import qualified Data.Text as X
+import qualified Data.Traversable as Tr
+import qualified System.Console.MultiArg as MA
+import qualified Penny.Lincoln as L
+import qualified Penny.Liberty as Ly
+import qualified Penny.Steel.Sums as S
+import qualified Control.Monad.Trans.State as St
+import qualified Control.Monad.Trans.Maybe as MT
+import Control.Monad.Trans.Class (lift)
+import qualified Penny.Copper as C
+import qualified Penny.Copper.Render as R
+import Text.Show.Pretty (ppShow)
+import qualified Penny.Brenner.Types as Y
+import qualified Penny.Brenner.Util as U
+
+
+help :: String -> String
+help pn = unlines
+ [ "usage: " ++ pn ++ " clear [options] FIT_FILE LEDGER_FILE..."
+ , "Parses all postings that are in FIT_FILE. Then marks all"
+ , "postings that are in the FILEs given that correspond to one"
+ , "of the postings in the FIT_FILE as being cleared."
+ , "Quits if one of the postings found in FIT_FILE is not found"
+ , "in the database, if one of the postings in the database"
+ , "is not found in one of the FILEs, or if any of the postings found"
+ , "in one of the FILEs already has a flag."
+ , ""
+ , "Results are printed to standard output. If no FILE, or FILE is \"-\","
+ , "read standard input."
+ , ""
+ , "Options:"
+ , " -o, --output FILENAME - send output to FILENAME"
+ , " (default: send to standard output)"
+ , " -h, --help - show help and exit"
+ ]
+
+data Arg
+ = APosArg String
+ | AOutput (X.Text -> IO ())
+
+toPosArg :: Arg -> Maybe String
+toPosArg a = case a of { APosArg s -> Just s; _ -> Nothing }
+
+toOutput :: Arg -> Maybe (X.Text -> IO ())
+toOutput a = case a of { AOutput x -> Just x; _ -> Nothing }
+
+data Opts = Opts
+ { csvLocation :: Y.FitFileLocation
+ , ledgerLocations :: [String]
+ , printer :: X.Text -> IO ()
+ } deriving Show
+
+
+mode :: Y.Mode
+mode mayFa = MA.modeHelp
+ "clear" -- Mode name
+ help -- Help function
+ (process mayFa) -- Processor
+ [fmap AOutput Ly.output] -- Options
+ MA.Intersperse -- interspersion
+ (return . APosArg) -- Posarg processor
+
+
+process :: Maybe Y.FitAcct -> [Arg] -> IO ()
+process mayFa as = do
+ fa <- U.getFitAcct mayFa
+ (csv, ls) <- case mapMaybe toPosArg as of
+ [] -> fail "clear: you must provide a postings file."
+ x:xs -> return (Y.FitFileLocation x, xs)
+ let os = Opts csv ls (Ly.processOutput . mapMaybe toOutput $ as)
+ runClear fa os
+
+runClear :: Y.FitAcct -> Opts -> IO ()
+runClear c os = do
+ dbList <- U.loadDb (Y.AllowNew False) (Y.dbLocation c)
+ let db = M.fromList dbList
+ (_, prsr) = Y.parser c
+ txns <- fmap (Ex.switch fail return) $ prsr (csvLocation os)
+ leds <- C.open (ledgerLocations os)
+ toClear <- case mapM (findUNumber db) (concat txns) of
+ Nothing -> fail $ "at least one posting was not found in the"
+ ++ " database. Ensure all postings have "
+ ++ "been imported and merged."
+ Just ls -> return $ Set.fromList ls
+ let (led', left) = changeLedger (Y.pennyAcct c) toClear leds
+ led'' = map C.stripMeta led'
+ when (not (Set.null left))
+ (fail $ "some postings were not cleared. "
+ ++ "Those not cleared:\n" ++ ppShow left)
+ case mapM (R.item Nothing) led'' of
+ Nothing ->
+ fail "could not render resulting ledger."
+ Just txts ->
+ let glued = X.concat txts
+ in glued `seq` printer os glued
+
+
+-- | Examines an financial institution transaction and the DbMap to
+-- find a matching UNumber. Fails if the financial institution
+-- transaction is not in the Db.
+findUNumber :: Y.DbMap -> Y.Posting -> Maybe Y.UNumber
+findUNumber m pstg =
+ let atn = Y.fitId pstg
+ p ap = Y.fitId ap == atn
+ filteredMap = M.filter p m
+ ls = M.toList filteredMap
+ in case ls of
+ (n, _):[] -> Just n
+ _ -> Nothing
+
+
+clearedFlag :: L.Flag
+clearedFlag = L.Flag . X.singleton $ 'C'
+
+-- | Changes a ledger to clear postings. Returns postings still not
+-- cleared.
+changeLedger
+ :: Y.PennyAcct
+ -> Set.Set Y.UNumber
+ -> [C.LedgerItem]
+ -> ([C.LedgerItem], Set.Set Y.UNumber)
+changeLedger ax s l = St.runState k s
+ where
+ k = mapM f l
+ f x = case x of
+ S.S4a t -> fmap S.S4a $ changeTxn ax t
+ S.S4b z -> fmap S.S4b $ return z
+ S.S4c z -> fmap S.S4c $ return z
+ S.S4d z -> fmap S.S4d $ return z
+
+changeTxn
+ :: Y.PennyAcct
+ -> L.Transaction
+ -> St.State (Set.Set Y.UNumber) L.Transaction
+changeTxn ax (L.Transaction (tld, d)) =
+ (\tl es -> L.Transaction (tl, es))
+ <$> pure tld
+ <*> Tr.mapM (changePstg ax) d
+
+
+-- | Sees if this posting is a posting in the right account and has a
+-- UNumber that needs to be cleared. If so, clears it. If this posting
+-- already has a flag, skips it.
+changePstg
+ :: Y.PennyAcct
+ -> L.PostingData
+ -> St.State (Set.Set Y.UNumber) L.PostingData
+changePstg ax p =
+ fmap (fromMaybe p) . MT.runMaybeT $ do
+ let c = L.pdCore p
+ guard (L.pAccount c == (Y.unPennyAcct ax))
+ let tags = L.pTags c
+ un <- maybe mzero return $ parseUNumberFromTags tags
+ guard (L.pFlag c == Nothing)
+ set <- lift St.get
+ guard (Set.member un set)
+ lift $ St.put (Set.delete un set)
+ let c' = c { L.pFlag = Just clearedFlag }
+ return $ p { L.pdCore = c' }
+
+parseUNumberFromTags :: L.Tags -> Maybe Y.UNumber
+parseUNumberFromTags =
+ getFirst
+ . mconcat
+ . map First
+ . map parseUNumberFromTag
+ . L.unTags
+
+parseUNumberFromTag :: L.Tag -> Maybe Y.UNumber
+parseUNumberFromTag (L.Tag x) = do
+ (f, xs) <- X.uncons x
+ guard (f == 'U')
+ case reads . X.unpack $ xs of
+ (u, ""):[] -> Just (Y.UNumber u)
+ _ -> Nothing
+
diff --git a/lib/Penny/Brenner/Database.hs b/lib/Penny/Brenner/Database.hs
new file mode 100644
index 0000000..c00bda7
--- /dev/null
+++ b/lib/Penny/Brenner/Database.hs
@@ -0,0 +1,40 @@
+module Penny.Brenner.Database (mode) where
+
+import qualified Penny.Brenner.Types as Y
+import qualified Penny.Brenner.Util as U
+import qualified System.Console.MultiArg as MA
+
+help :: String -> String
+help pn = unlines
+ [ "usage: " ++ pn ++ " [global-options] database [local-options]"
+ , "Shows the database of financial institution transactions."
+ , "Does not accept any non-option arguments."
+ , ""
+ , "Local options:"
+ , " --help, -h Show this help and exit."
+ ]
+
+data Arg = ArgPos String
+
+mode :: Y.Mode
+mode mayFa = MA.modeHelp
+ "database" -- Mode name
+ help -- Help function
+ (processor mayFa) -- Processing function
+ [] -- Options
+ MA.Intersperse -- Interspersion
+ (return . ArgPos) -- Posarg processor
+
+processor
+ :: Maybe Y.FitAcct
+ -> [Arg]
+ -> IO ()
+processor mayFa ls
+ | not . null $ ls = fail $
+ "penny-fit database: error: this command does"
+ ++ " not accept non-option arguments."
+ | otherwise = do
+ fa <- U.getFitAcct mayFa
+ let dbLoc = Y.dbLocation fa
+ db <- U.loadDb (Y.AllowNew False) dbLoc
+ mapM_ putStr . map U.showDbPair $ db
diff --git a/lib/Penny/Brenner/Import.hs b/lib/Penny/Brenner/Import.hs
new file mode 100644
index 0000000..5d78615
--- /dev/null
+++ b/lib/Penny/Brenner/Import.hs
@@ -0,0 +1,140 @@
+module Penny.Brenner.Import (mode) where
+
+import Control.Applicative ((<|>))
+import qualified Control.Monad.Exception.Synchronous as Ex
+import Data.Maybe (mapMaybe)
+import qualified System.Console.MultiArg as MA
+import qualified Penny.Brenner.Types as Y
+import qualified Penny.Brenner.Util as U
+
+data Arg
+ = AFitFile String
+ | AAllowNew
+ | AUNumber Integer
+
+toFitFile :: Arg -> Maybe String
+toFitFile a = case a of
+ AFitFile s -> Just s
+ _ -> Nothing
+
+toNewUNumber :: [Arg] -> Maybe Integer
+toNewUNumber as =
+ let f i = case i of { AUNumber x -> Just x; _ -> Nothing }
+ in case mapMaybe f as of
+ [] -> Nothing
+ xs -> Just $ last xs
+
+data ImportOpts = ImportOpts
+ { fitFile :: Y.FitFileLocation
+ , allowNew :: Y.AllowNew
+ , parser :: Y.FitFileLocation
+ -> IO (Ex.Exceptional String [Y.Posting])
+ , newUNumber :: Maybe Integer
+ }
+
+mode :: Y.Mode
+mode mayFa = MA.modeHelp
+ "import" -- Mode name
+ help -- Help function
+ (processor mayFa) -- Processing function
+ opts -- Options
+ MA.Intersperse -- Interspersion
+ (return . AFitFile) -- Posarg processor
+ where
+ opts =
+ [ MA.OptSpec ["new"] "n" (MA.NoArg AAllowNew)
+ , MA.OptSpec ["unumber"] "u" . MA.OneArgE $ \s -> do
+ i <- MA.reader s
+ return $ AUNumber i
+ ]
+
+processor
+ :: Maybe Y.FitAcct
+ -> [Arg]
+ -> IO ()
+processor mayFa as = do
+ fa <- U.getFitAcct mayFa
+ let (dbLoc, prsr) = (Y.dbLocation fa, snd . Y.parser $ fa)
+ loc <- case mapMaybe toFitFile as of
+ [] -> fail "you must provide a postings file to read"
+ x:[] -> return (Y.FitFileLocation x)
+ _ -> fail "you cannot provide more than one postings file to read"
+ let aNew = Y.AllowNew
+ $ any (\a -> case a of { AAllowNew -> True; _ -> False }) as
+ maybeNewU = toNewUNumber as
+ doImport dbLoc (ImportOpts loc aNew prsr maybeNewU)
+
+
+-- | Appends new Amex transactions to the existing list.
+appendNew
+ :: Maybe Integer
+ -- ^ If Just, this is the new U-number for the first
+ -- transaction. Otherwise, the next U number will be the one that is
+ -- one larger than the current maximum in the database.
+
+ -> [(Y.UNumber, Y.Posting)]
+ -- ^ Existing transactions
+
+ -> [Y.Posting]
+ -- ^ New transactions
+
+ -> Maybe ([(Y.UNumber, Y.Posting)], Int)
+ -- ^ New list, and number of transactions added. Fails if the new U
+ -- number was passed in the first argument and this number is not
+ -- valid.
+
+appendNew mu db new =
+ let currFitIds = map (Y.fitId . snd) db
+ isNew p = not (any (== Y.fitId p) currFitIds)
+ newPstgs = filter isNew new
+ mkPair i p = (Y.UNumber i, p)
+ maybeU = nextUNum mu db
+ in fmap (\u -> let newWithU = (zipWith mkPair [u..] newPstgs)
+ in (db ++ newWithU, length newWithU)) maybeU
+
+nextUNum
+ :: Maybe Integer
+ -> [(Y.UNumber, Y.Posting)]
+ -> Maybe Integer
+nextUNum mu db =
+ let defaultU = if null db then Nothing
+ else Just $ ( Y.unUNumber . maximum
+ . map fst $ db) + 1
+ in case mu of
+ Nothing -> defaultU <|> Just 0
+ Just u -> case defaultU of
+ Nothing -> if u >= 0 then Just u else Nothing
+ Just du -> if u >= du then Just u else Nothing
+
+doImport :: Y.DbLocation -> ImportOpts -> IO ()
+doImport dbLoc os = do
+ txnsOld <- U.loadDb (allowNew os) dbLoc
+ parseResult <- parser os (fitFile os)
+ ins <- case parseResult of
+ Ex.Exception e -> fail e
+ Ex.Success g -> return g
+ (new, len) <- case appendNew (newUNumber os) txnsOld ins of
+ Just r -> return r
+ Nothing -> fail "invalid new U number given."
+ U.saveDb dbLoc new
+ putStrLn $ "imported " ++ show len ++ " new transactions."
+
+help :: String -> String
+help pn = unlines
+ [ "usage: " ++ pn ++ " [global-options] import [local-options] FIT_FILE"
+ , "where FIT_FILE is the file downloaded from the financial"
+ , "institution."
+ , ""
+ , "Local Options:"
+ , ""
+ , "-n, --new - Allows creation of new database. Without this option,"
+ , "if the database file is not found, quits with an error."
+ , ""
+ , "-u, --unumber - The first U number assigned will be this number."
+ , "Fails if the number you give is not greater than the largest"
+ , "U number already in the database."
+ , ""
+ , "-h, --help - Show this help."
+ , ""
+ ]
+
diff --git a/lib/Penny/Brenner/Info.hs b/lib/Penny/Brenner/Info.hs
new file mode 100644
index 0000000..d851213
--- /dev/null
+++ b/lib/Penny/Brenner/Info.hs
@@ -0,0 +1,135 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Penny.Brenner.Info (mode) where
+
+import qualified Control.Monad.Exception.Synchronous as Ex
+import qualified Penny.Brenner.Types as Y
+import qualified Data.Text as X
+import qualified Data.Text.IO as TIO
+import Data.Monoid ((<>))
+import qualified Penny.Lincoln as L
+import qualified Penny.Steel.Sums as S
+import qualified System.Console.MultiArg as MA
+
+help :: String -> String
+help pn = unlines
+ [ "usage: " ++ pn ++ " info [options]"
+ , "Shows further information about the configuration of your"
+ , "financial institution accounts."
+ , ""
+ , "Options:"
+ , " -h, --help - show help and exit"
+ ]
+
+mode :: Y.Config -> MA.Mode (MA.ProgName -> String) (IO ())
+mode cf = MA.modeHelp
+ "info" -- Mode name
+ help -- Help function
+ (const (process cf)) -- Processing function
+ [] -- Options
+ MA.Intersperse -- Interspersion
+ processPa -- Posarg processor
+ where
+ processPa = const . Ex.throw . MA.ErrorMsg
+ $ "this mode does not accept positional arguments"
+
+process :: Y.Config -> IO ()
+process cf = TIO.putStr $ showInfo cf
+
+showInfo :: Y.Config -> X.Text
+showInfo cf =
+ "These settings are compiled into your program.\n\n"
+ <> showConfig cf
+
+showConfig :: Y.Config -> X.Text
+showConfig (Y.Config dflt more) =
+ "Default financial institution account:"
+ <> case dflt of
+ Nothing -> " (no default)\n\n"
+ Just d -> "\n\n" <> showFitAcct d <> "\n"
+ <> "Additional financial institution accounts:"
+ <> case more of
+ [] -> " no additional accounts\n"
+ ls -> "\n\n" <> showFitAccts ls
+
+sepBar :: X.Text
+sepBar = X.replicate 40 "=" <> "\n"
+
+sepWithSpace :: X.Text
+sepWithSpace = "\n" <> sepBar <> "\n"
+
+showFitAccts :: [Y.FitAcct] -> X.Text
+showFitAccts = X.intercalate sepWithSpace . map showFitAcct
+
+label :: X.Text -> X.Text -> X.Text
+label l t = l <> ": " <> t
+
+showFitAcct :: Y.FitAcct -> X.Text
+showFitAcct c =
+ (L.text . Y.fitAcctName $ c) <> "\n\n"
+ <> (L.text . Y.fitAcctDesc $ c) <> "\n"
+ <> X.unlines
+ [ label "Database location" (L.text . Y.dbLocation $ c)
+ , label "Penny account" (L.text . L.Delimited ":" . Y.pennyAcct $ c)
+ , label "Default account" (L.text . L.Delimited ":" . Y.defaultAcct $ c)
+ , label "Currency" (L.text . Y.currency $ c)
+ , label "Radix point and digit grouping"
+ (showQtySpec . Y.qtySpec $ c)
+
+ , label "Financial institution increases are"
+ (showTranslator . Y.translator $ c)
+
+ , label "In new postings, commodity is on the"
+ (showSide . Y.side $ c)
+
+ , label "Space between commodity and quantity in new postings"
+ (showSpaceBetween . Y.spaceBetween $ c)
+ ]
+ <> "Parser description:\n"
+ <> (L.text . fst . Y.parser $ c)
+
+showQtySpec :: S.S3 L.Radix L.PeriodGrp L.CommaGrp -> X.Text
+showQtySpec s = case s of
+ S.S3a r -> "no digit grouping, use radix point: '"
+ <> (L.showRadix r) <> "'"
+ S.S3b p -> "group digits using: '"
+ <> (X.singleton . L.groupChar $ p)
+ <> "', radix point: '.'"
+ S.S3c c -> "group digits using: '"
+ <> (X.singleton . L.groupChar $ c)
+ <> "', radix point: ','"
+
+
+showTranslator :: Y.Translator -> X.Text
+showTranslator y = case y of
+ Y.IncreaseIsDebit -> "debits"
+ Y.IncreaseIsCredit -> "credits"
+
+showSide :: L.Side -> X.Text
+showSide L.CommodityOnLeft = "left"
+showSide L.CommodityOnRight = "right"
+
+showSpaceBetween :: L.SpaceBetween -> X.Text
+showSpaceBetween L.SpaceBetween = "yes"
+showSpaceBetween L.NoSpaceBetween = "no"
+
+{-
+ label "Database location"
+ (X.unpack . Y.unDbLocation . Y.dbLocation $ c)
+
+ ++ label "Penny account"
+ (showAccount . Y.unPennyAcct . Y.pennyAcct $ c)
+
+ ++ label "Account for new offsetting postings"
+ (showAccount . Y.unDefaultAcct . Y.defaultAcct $ c)
+
+ ++ label "Currency"
+ (X.unpack . L.unCommodity . Y.unCurrency . Y.currency $ c)
+
+ ++ "\n"
+
+ ++ "More information about the parser:\n"
+ ++ (Y.unParserDesc . fst . Y.parser $ c)
+ ++ "\n\n"
+
+
+-}
diff --git a/lib/Penny/Brenner/Merge.hs b/lib/Penny/Brenner/Merge.hs
new file mode 100644
index 0000000..85d9b49
--- /dev/null
+++ b/lib/Penny/Brenner/Merge.hs
@@ -0,0 +1,370 @@
+module Penny.Brenner.Merge (mode) where
+
+import Control.Applicative
+import Control.Monad (guard)
+import qualified Control.Monad.Trans.State as St
+import Data.List (find, sortBy, foldl')
+import qualified Data.Map as M
+import Data.Maybe (mapMaybe, isNothing, fromMaybe)
+import Data.Monoid (First(..), mconcat)
+import qualified Data.Text as X
+import qualified System.Console.MultiArg as MA
+import qualified Penny.Copper as C
+import qualified Penny.Copper.Render as R
+import qualified Penny.Lincoln as L
+import qualified Penny.Liberty as Ly
+import qualified Penny.Lincoln.Queries as Q
+import qualified Penny.Brenner.Types as Y
+import qualified Penny.Brenner.Util as U
+import qualified Penny.Steel.Sums as S
+
+type NoAuto = Bool
+
+data Arg
+ = APos String
+ | ANoAuto
+ | AOutput (X.Text -> IO ())
+
+instance Eq Arg where
+ APos l == APos r = l == r
+ ANoAuto == ANoAuto = True
+ _ == _ = False
+
+toPosArg :: Arg -> Maybe String
+toPosArg a = case a of { APos s -> Just s; _ -> Nothing }
+
+toOutput :: Arg -> Maybe (X.Text -> IO ())
+toOutput a = case a of { AOutput x -> Just x; _ -> Nothing }
+
+mode :: Y.Mode
+mode mayFa = MA.modeHelp
+ "merge"
+ help
+ (processor mayFa)
+ opts
+ MA.Intersperse
+ (return . APos)
+ where
+ opts = [ MA.OptSpec ["no-auto"] "n" (MA.NoArg ANoAuto)
+ , fmap AOutput Ly.output
+ ]
+
+processor :: Maybe Y.FitAcct -> [Arg] -> IO ()
+processor mayFa as = do
+ fa <- U.getFitAcct mayFa
+ doMerge fa
+ (ANoAuto `elem` as)
+ (Ly.processOutput . mapMaybe toOutput $ as)
+ (mapMaybe toPosArg as)
+
+doMerge
+ :: Y.FitAcct
+ -> NoAuto
+ -> (X.Text -> IO ())
+ -- ^ Function to handle the output
+ -> [String]
+ -- ^ Ledger filenames to open
+ -> IO ()
+doMerge acct noAuto printer ss = do
+ dbLs <- U.loadDb (Y.AllowNew False) (Y.dbLocation acct)
+ l <- C.open ss
+ let dbWithEntry = fmap (pairWithEntry acct) . M.fromList $ dbLs
+ (l', db') = changeItems acct
+ l (filterDb (Y.pennyAcct acct) dbWithEntry l)
+ newTxns = createTransactions noAuto acct l dbLs db'
+ final = l' ++ newTxns
+ case mapM (R.item Nothing) (map C.stripMeta final) of
+ Nothing -> fail "Could not render final ledger."
+ Just txts ->
+ let txt = X.concat txts
+ in txt `seq` printer txt
+
+
+help :: String -> String
+help pn = unlines
+ [ "usage: " ++ pn ++ " merge: merges new transactions from database"
+ , "to ledger file."
+ , "usage: penny-fit merge [options] FILE..."
+ , "Results are printed to standard output. If no FILE, or if FILE is -,"
+ , "read standard input."
+ , ""
+ , "Options:"
+ , " -n, --no-auto - do not automatically assign payees and accounts"
+ , " -o, --output FILENAME - send output to FILENAME"
+ , " (default: send to standard output)"
+ , " -h, --help - show help and exit"
+ ]
+
+-- | Removes all Brenner postings that already have a Penny posting
+-- with the correct uNumber.
+filterDb :: Y.PennyAcct -> DbWithEntry -> [C.LedgerItem] -> DbWithEntry
+filterDb ax m l = M.difference m ml
+ where
+ ml = M.fromList
+ . flip zip (repeat ())
+ . mapMaybe toUNum
+ . filter inPennyAcct
+ . concatMap L.transactionToPostings
+ . ( let cn = const Nothing
+ in mapMaybe (S.caseS4 Just cn cn cn))
+ $ l
+ inPennyAcct p = Q.account p == (Y.unPennyAcct ax)
+ toUNum p = getUNumberFromTags . Q.tags $ p
+
+-- | Gets the first UNumber from a list of Tags.
+getUNumberFromTags :: L.Tags -> Maybe Y.UNumber
+getUNumberFromTags =
+ getFirst
+ . mconcat
+ . map First
+ . map getUNumberFromTag
+ . L.unTags
+
+-- | Examines a tag to see if it is a uNumber. If so, returns the
+-- UNumber. Otherwise, returns Nothing.
+getUNumberFromTag :: L.Tag -> Maybe Y.UNumber
+getUNumberFromTag (L.Tag x) = do
+ (f, r) <- X.uncons x
+ guard (f == 'U')
+ case reads . X.unpack $ r of
+ (y, ""):[] -> return $ Y.UNumber y
+ _ -> Nothing
+
+
+-- | Changes a single Item.
+changeItem
+ :: Y.FitAcct
+ -> C.LedgerItem
+ -> St.State DbWithEntry C.LedgerItem
+changeItem acct =
+ S.caseS4 (fmap S.S4a . changeTransaction acct)
+ (return . S.S4b) (return . S.S4c) (return . S.S4d)
+
+
+-- | Changes all postings that match an AmexTxn to assign them the
+-- proper UNumber. Returns a list of changed items, and the DbMap of
+-- still-unassigned AmexTxns.
+changeItems
+ :: Y.FitAcct
+ -> [C.LedgerItem]
+ -> DbWithEntry
+ -> ([C.LedgerItem], DbWithEntry)
+changeItems acct l = St.runState (mapM (changeItem acct) l)
+
+
+changeTransaction
+ :: Y.FitAcct
+ -> L.Transaction
+ -> St.State DbWithEntry L.Transaction
+changeTransaction acct txn =
+ (\tl es -> L.Transaction (tl, es))
+ <$> pure (fst . L.unTransaction $ txn)
+ <*> L.traverseEnts (inspectAndChange acct
+ (fst . L.unTransaction $ txn))
+ (snd . L.unTransaction $ txn)
+
+-- | Inspects a posting to see if it is an Amex posting and, if so,
+-- whether it matches one of the remaining AmexTxns. If so, then
+-- changes the transaction's UNumber, and remove that UNumber from the
+-- DbMap. If the posting alreay has a Number (UNumber or otherwise)
+-- skips it.
+inspectAndChange
+ :: Y.FitAcct
+ -> L.TopLineData
+ -> L.Ent L.PostingData
+ -> St.State DbWithEntry L.PostingData
+inspectAndChange acct tld p = do
+ m <- St.get
+ case findMatch acct tld p m of
+ Nothing -> return (L.meta p)
+ Just (n, m') ->
+ let c = L.pdCore . L.meta $ p
+ L.Tags oldTags = L.pTags c
+ tags' = L.Tags (oldTags ++ [newLincolnUNumber n])
+ c' = c { L.pTags = tags' }
+ p' = (L.meta p) { L.pdCore = c' }
+ in St.put m' >> return p'
+
+newLincolnUNumber :: Y.UNumber -> L.Tag
+newLincolnUNumber a =
+ L.Tag ('U' `X.cons` (X.pack . show . Y.unUNumber $ a))
+
+
+-- | Searches a DbMap for an AmexTxn that matches a given posting. If
+-- a match is found, returns the matching UNumber and a new DbMap that
+-- has the match removed.
+findMatch
+ :: Y.FitAcct
+ -> L.TopLineData
+ -> L.Ent L.PostingData
+ -> DbWithEntry
+ -> Maybe (Y.UNumber, DbWithEntry)
+findMatch acct tl p m = fmap toResult findResult
+ where
+ findResult = find (pennyTxnMatches acct tl p)
+ . M.toList $ m
+ toResult (u, (_, _)) = (u, M.delete u m)
+
+-- | Pairs each association in a DbMap with an Entry representing the
+-- transaction's entry in the ledger.
+pairWithEntry :: Y.FitAcct -> Y.Posting -> (Y.Posting, L.Entry L.Qty)
+pairWithEntry acct p = (p, en)
+ where
+ en = L.Entry dc (L.Amount qty cty)
+ dc = Y.translate (Y.incDec p) (Y.translator acct)
+ qty = U.parseQty (Y.amount p)
+ cty = Y.unCurrency . Y.currency $ acct
+
+type DbWithEntry = M.Map Y.UNumber (Y.Posting, L.Entry L.Qty)
+
+-- | Does the given Penny transaction match this posting? Makes sure
+-- that the account, quantity, date, commodity, and DrCr match, and
+-- that the posting does not have a number (it's OK if the transaction
+-- has a number.)
+pennyTxnMatches
+ :: Y.FitAcct
+ -> L.TopLineData
+ -> L.Ent L.PostingData
+ -> (a, (Y.Posting, L.Entry L.Qty))
+ -> Bool
+pennyTxnMatches acct tl pstg (_, (a, e)) =
+ mA && noFlag && mQ && mDC && mDate && mCmdty
+ where
+ p = L.pdCore . L.meta $ pstg
+ mA = L.pAccount p == (Y.unPennyAcct . Y.pennyAcct $ acct)
+ mQ = L.equivalent (eitherToQty . L.entry $ pstg)
+ (L.qty . L.amount $ e)
+ mDC = (L.drCr e) == (either L.drCr L.drCr . L.entry $ pstg)
+ mDate = (L.day . L.tDateTime . L.tlCore $ tl) == (Y.unDate . Y.date $ a)
+ noFlag = isNothing . L.pNumber $ p
+ mCmdty = (eitherToCmdty . L.entry $ pstg)
+ == (Y.unCurrency . Y.currency $ acct)
+
+
+eitherToCmdty :: Either (L.Entry a) (L.Entry b) -> L.Commodity
+eitherToCmdty = either (L.commodity . L.amount) (L.commodity . L.amount)
+
+eitherToQty :: Either (L.Entry L.QtyRep) (L.Entry L.Qty) -> L.Qty
+eitherToQty = either (L.toQty . L.qty . L.amount)
+ (L.toQty . L.qty . L.amount)
+
+-- | Creates a new transaction corresponding to a given AmexTxn. Uses
+-- the Amex payee if that string is non empty; otherwise, uses the
+-- Amex description for the payee.
+newTransaction
+ :: NoAuto
+ -> Y.FitAcct
+ -> UNumberLookupMap
+ -> PyeLookupMap
+ -> (Y.UNumber, (Y.Posting, L.Entry L.Qty))
+ -> L.Transaction
+newTransaction noAuto acct mu mp (u, (a, e))
+ = L.Transaction (tld, ents) where
+ tld = L.TopLineData tlc Nothing Nothing
+ tlc = (L.emptyTopLineCore (L.dateTimeMidnightUTC . Y.unDate . Y.date $ a))
+ { L.tPayee = Just pa }
+ (pa, ac) = if noAuto then (dfltPye, dfltAcct)
+ else ( fromMaybe dfltPye guessedPye,
+ fromMaybe dfltAcct guessedAcct)
+ (guessedPye, guessedAcct) = guessInfo (Y.toLincolnPayee acct) mu mp a
+ dfltPye = getPye (Y.desc a) (Y.payee a)
+ dfltAcct = Y.unDefaultAcct . Y.defaultAcct $ acct
+ getPye = Y.toLincolnPayee acct
+ pennyAcct = Y.unPennyAcct . Y.pennyAcct $ acct
+ p1data = L.PostingData p1core Nothing Nothing
+ p2data = L.PostingData p2core Nothing Nothing
+ p1core = (L.emptyPostingCore pennyAcct)
+ { L.pTags = L.Tags [newLincolnUNumber u]
+ , L.pSide = Just $ Y.side acct
+ , L.pSpaceBetween = Just $ Y.spaceBetween acct
+ }
+ p2core = L.emptyPostingCore ac
+ ents = L.rEnts (Y.unCurrency . Y.currency $ acct) (L.drCr e)
+ (Left . L.qtyToRep gs . L.qty . L.amount $ e, p1data)
+ [] p2data
+ gs = Y.qtySpec acct
+
+-- | Creates new transactions for all the items remaining in the
+-- DbMap. Appends a blank line after each one.
+createTransactions
+ :: NoAuto
+ -> Y.FitAcct
+ -> [C.LedgerItem]
+ -> Y.DbList
+ -> DbWithEntry
+ -> [C.LedgerItem]
+createTransactions noAuto acct led dbLs db =
+ concatMap (\i -> [i, S.S4d C.BlankLine])
+ . map S.S4a
+ . map (newTransaction noAuto acct mu mp)
+ . M.assocs
+ $ db
+ where
+ mu = makeUNumberLookup (Y.toLincolnPayee acct) dbLs
+ mp = makePyeLookupMap (Y.pennyAcct acct) led
+
+-- | Maps financial institution postings to UNumbers. The key is the
+-- Lincoln Payee of the financial institution posting, which is
+-- computed using the toLincolnPayee function in the FitAcct. The
+-- UNumbers are in a list, with UNumbers from most recent financial
+-- institution postings first.
+type UNumberLookupMap = M.Map L.Payee [Y.UNumber]
+
+-- | Create a UNumberLookupMap from a DbWithEntry. Financial
+-- institution postings with higher U-numbers will come first.
+makeUNumberLookup
+ :: (Y.Desc -> Y.Payee -> L.Payee)
+ -> Y.DbList
+ -> UNumberLookupMap
+makeUNumberLookup toPye = foldl' ins M.empty . map f . sortBy g
+ where
+ ins m (k, v) = M.alter alterer k m
+ where alterer Nothing = Just [v]
+ alterer (Just ls) = Just $ v:ls
+ f (u, p) = (toPye (Y.desc p) (Y.payee p), u)
+ g (_, p1) (_, p2) = compare (Y.date p1) (Y.date p2)
+
+-- | Given a list of keys, find the first key that is in the
+-- map. Returns Nothing if no key is in the map.
+findFirstKey :: Ord k => M.Map k v -> [k] -> Maybe v
+findFirstKey _ [] = Nothing
+findFirstKey m (k:ks) = case M.lookup k m of
+ Nothing -> findFirstKey m ks
+ Just v -> Just v
+
+-- | Maps UNumbers to payees and accounts from the ledger.
+type PyeLookupMap = M.Map Y.UNumber (Maybe L.Payee, Maybe L.Account)
+
+-- | Makes a payee lookup map. Puts those postings which match the
+-- PennyAcct and have a UNumber into the map. (If two postings match
+-- the PennyAcct and have the same UNumber, the one that appears later
+-- in the ledger file will be in the map.)
+makePyeLookupMap :: Y.PennyAcct -> [C.LedgerItem] -> PyeLookupMap
+makePyeLookupMap a l
+ = M.fromList . mapMaybe f . concatMap L.transactionToPostings
+ . mapMaybe toPstg
+ $ l
+ where
+ f pstg = do
+ guard $ (Q.account pstg) == Y.unPennyAcct a
+ u <- getUNumberFromTags . Q.tags $ pstg
+ let tailents = L.tailEnts . snd . L.unPosting $ pstg
+ ac = case tailents of
+ (x, []) -> Just (L.pAccount . L.pdCore . L.meta $ x)
+ _ -> Nothing
+ return (u, (Q.payee pstg, ac))
+ toPstg = let cn = const Nothing in S.caseS4 Just cn cn cn
+
+-- | Given a UNumber and the maps, looks up the payee and account
+-- information from previous transactions if this information is
+-- available.
+guessInfo
+ :: (Y.Desc -> Y.Payee -> L.Payee)
+ -> UNumberLookupMap
+ -> PyeLookupMap
+ -> Y.Posting
+ -> (Maybe L.Payee, Maybe L.Account)
+guessInfo getPye mu mp p = fromMaybe (Nothing, Nothing) $ do
+ let pstgPayee = getPye (Y.desc p) (Y.payee p)
+ unums <- M.lookup pstgPayee mu
+ findFirstKey mp unums
diff --git a/lib/Penny/Brenner/OFX.hs b/lib/Penny/Brenner/OFX.hs
new file mode 100644
index 0000000..ee0c925
--- /dev/null
+++ b/lib/Penny/Brenner/OFX.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Parses any OFX 1.0-series file. Uses the parser from the ofx
+-- package.
+--
+-- The Postings that this module returns /always/ have an empty
+-- Description field. Information from the OFX Payee field is placed
+-- into the Payee field of the Posting record.
+
+module Penny.Brenner.OFX (parser) where
+
+import Control.Applicative
+import qualified Control.Monad.Exception.Synchronous as Ex
+import Data.List (isPrefixOf)
+import qualified Data.OFX as O
+import qualified Data.Text as X
+import qualified Data.Time as T
+import qualified Penny.Brenner.Types as Y
+import qualified Text.Parsec as P
+
+-- | Parser for OFX files.
+parser :: ( Y.ParserDesc, Y.ParserFn )
+parser = (Y.ParserDesc d, loadIncoming)
+ where
+ d = X.unlines
+ [ "Parses OFX 1.0-series files."
+ , "Open Financial Exchange (OFX) is a standard format"
+ , "for providing financial information. It is documented"
+ , "at http://www.ofx.net"
+ , "This parser also handles QFX files, which are OFX"
+ , "files with minor additions by the makers of Quicken."
+ , "Many banks make this format available with the label"
+ , "\"Download to Quicken\" or similar."
+ ]
+
+loadIncoming
+ :: Y.FitFileLocation
+ -> IO (Ex.Exceptional String [Y.Posting])
+loadIncoming (Y.FitFileLocation fn) = do
+ contents <- readFile fn
+ return $
+ ( Ex.mapException show
+ . Ex.fromEither
+ $ P.parse O.ofxFile fn contents )
+ >>= O.transactions
+ >>= mapM txnToPosting
+
+
+txnToPosting
+ :: O.Transaction
+ -> Ex.Exceptional String Y.Posting
+txnToPosting t = Y.Posting
+ <$> pure (Y.Date ( T.utctDay . T.zonedTimeToUTC
+ . O.txDTPOSTED $ t))
+ <*> pure (Y.Desc X.empty)
+ <*> pure incDec
+ <*> amt
+ <*> pure ( Y.Payee $ case O.txPayeeInfo t of
+ Nothing -> X.empty
+ Just ei -> case ei of
+ Left x -> X.pack x
+ Right p -> X.pack . O.peNAME $ p )
+ <*> pure (Y.FitId . X.pack . O.txFITID $ t)
+ where
+ amtStr = O.txTRNAMT t
+ incDec =
+ if "-" `isPrefixOf` amtStr then Y.Decrease else Y.Increase
+ amt = case amtStr of
+ [] -> Ex.throw "empty amount"
+ x:xs -> let str = if x == '-' || x == '+' then xs else amtStr
+ in Ex.fromMaybe ("could not parse amount: " ++ amtStr)
+ $ Y.mkAmount str
+
diff --git a/lib/Penny/Brenner/Print.hs b/lib/Penny/Brenner/Print.hs
new file mode 100644
index 0000000..29893a5
--- /dev/null
+++ b/lib/Penny/Brenner/Print.hs
@@ -0,0 +1,57 @@
+-- | Prints parsed transactions.
+--
+-- TODO add support to this and other Brenner components for reading
+-- from stdin.
+module Penny.Brenner.Print (mode) where
+
+import qualified Penny.Brenner.Types as Y
+import qualified Penny.Brenner.Util as U
+import qualified System.Console.MultiArg as MA
+import qualified Control.Monad.Exception.Synchronous as Ex
+import Data.Maybe (mapMaybe)
+
+help :: String -> String
+help pn = unlines
+ [ "usage: " ++ pn ++ " [global-options] print [local-options] FILE..."
+ , "Parses the transactions in each FILE using the appropriate parser"
+ , "and prints the parse result to standard output."
+ , ""
+ , "Local options:"
+ , " --help, -h Show this help and exit."
+ ]
+
+data Arg
+ = ArgFile String
+
+mode :: Y.Mode
+mode mayFa = MA.modeHelp
+ "print"
+ help
+ (processor mayFa)
+ []
+ MA.Intersperse
+ (return . ArgFile)
+
+processor
+ :: Maybe Y.FitAcct
+ -> [Arg]
+ -> IO ()
+processor mayFa ls = do
+ fa <- U.getFitAcct mayFa
+ doPrint (snd . Y.parser $ fa) ls
+
+doPrint
+ :: (Y.FitFileLocation -> IO (Ex.Exceptional String [Y.Posting]))
+ -> [Arg]
+ -> IO ()
+doPrint prsr ls = mapM_ f . mapMaybe toFile $ ls
+ where
+ f file = do
+ r <- prsr file
+ case r of
+ Ex.Exception s -> do
+ fail $ "penny-fit print: error: " ++ s
+ Ex.Success ps -> mapM putStr . map U.showPosting $ ps
+ toFile a = case a of
+ ArgFile s -> Just (Y.FitFileLocation s)
+
diff --git a/lib/Penny/Brenner/Types.hs b/lib/Penny/Brenner/Types.hs
new file mode 100644
index 0000000..90ebddf
--- /dev/null
+++ b/lib/Penny/Brenner/Types.hs
@@ -0,0 +1,340 @@
+module Penny.Brenner.Types
+ ( Date(..)
+ , IncDec(..)
+ , UNumber(..)
+ , FitId(..)
+ , Payee(..)
+ , Desc(..)
+ , Amount(unAmount)
+ , mkAmount
+ , translate
+ , DbMap
+ , DbList
+ , Posting(..)
+ , DbLocation(..)
+ , FitAcctName(..)
+ , FitAcctDesc(..)
+ , ParserDesc(..)
+ , PennyAcct(..)
+ , Translator(..)
+ , DefaultAcct(..)
+ , Currency(..)
+ , FitAcct(..)
+ , Config(..)
+ , FitFileLocation(..)
+ , AllowNew(..)
+ , ParserFn
+ , Mode
+ ) where
+
+import Control.Applicative ((<$>), (<*>))
+import qualified Control.Monad.Exception.Synchronous as Ex
+import qualified Data.Map as M
+import qualified Data.Time as Time
+import qualified Penny.Lincoln as L
+import Data.Text (Text, pack, unpack)
+import qualified Data.Text.Encoding as E
+import qualified Data.Serialize as S
+import qualified Penny.Steel.Sums as Su
+import qualified System.Console.MultiArg as MA
+
+-- | The type of all Brenner MultiArg modes.
+type Mode = Maybe FitAcct -> MA.Mode (MA.ProgName -> String) (IO ())
+
+-- | The date reported by the financial institution.
+newtype Date = Date { unDate :: Time.Day }
+ deriving (Eq, Show, Ord, Read)
+
+instance S.Serialize Date where
+ put = S.put . show . unDate
+ get = Date <$> (read <$> S.get)
+
+-- | Reports changes in account balances. Avoids using /debit/ and
+-- /credit/ as these terms are used differently by the bank than in
+-- your ledger (that is, the bank reports it from their perspective,
+-- not yours) so instead the terms /increase/ and /decrease/ are
+-- used. IncDec is used to record the bank's transactions so
+-- /increase/ and /decrease/ are used in the same way you would see
+-- them on a bank statement, whether it's a credit card, loan,
+-- checking account, etc.
+data IncDec
+ = Increase
+ -- ^ Increases the account balance. For a checking or savings
+ -- account, this is a deposit. For a credit card, this is a purchase.
+
+ | Decrease
+ -- ^ Decreases the account balance. On a credit card, this is a
+ -- payment. On a checking account, this is a withdrawal.
+ deriving (Eq, Show, Read)
+
+instance S.Serialize IncDec where
+ put x = case x of
+ Increase -> S.putWord8 0
+ Decrease -> S.putWord8 1
+ get = S.getWord8 >>= f
+ where
+ f x = case x of
+ 0 -> return Increase
+ 1 -> return Decrease
+ _ -> fail "read IncDec error"
+
+-- | A unique number assigned by Brenner to identify each
+-- posting. This is unique within a particular financial institution
+-- account only.
+newtype UNumber = UNumber { unUNumber :: Integer }
+ deriving (Eq, Show, Ord, Read)
+
+instance S.Serialize UNumber where
+ put = S.put . unUNumber
+ get = UNumber <$> S.get
+
+putText :: Text -> S.Put
+putText = S.put . E.encodeUtf8
+
+getText :: S.Get Text
+getText = S.get >>= f
+ where
+ f bs = case E.decodeUtf8' bs of
+ Left _ -> fail "text reading failed"
+ Right x -> return x
+
+
+-- | For Brenner to work, the bank has to assign unique identifiers to
+-- each transaction that it gives you for download. This is the
+-- easiest reliable way to ensure duplicates are not processed
+-- multiple times. (There are other ways to accomplish this, but they
+-- are much harder and less reliable.) If the bank does not do this,
+-- you can't use Brenner.
+newtype FitId = FitId { unFitId :: Text }
+ deriving (Eq, Show, Ord, Read)
+
+instance S.Serialize FitId where
+ put = putText . unFitId
+ get = FitId <$> getText
+
+-- | Some financial institutions assign a separate Payee in addition
+-- to a description. Others just have a single Description field. If
+-- this institution uses both, put something here. Brenner will prefer
+-- the Payee if it is not zero length; then it will use the Desc.
+newtype Payee = Payee { unPayee :: Text }
+ deriving (Eq, Show, Ord, Read)
+
+instance S.Serialize Payee where
+ put = putText . unPayee
+ get = Payee <$> getText
+
+-- | The transaction description. Some institutions assign only a
+-- description (sometimes muddling a payee with long codes, some
+-- dates, etc). Brenner prefers the Payee if there is one, and uses a
+-- Desc otherwise.
+newtype Desc =
+ Desc { unDesc :: Text }
+ deriving (Eq, Show, Ord, Read)
+
+instance S.Serialize Desc where
+ put = putText . unDesc
+ get = Desc <$> getText
+
+-- | The amount of the transaction. Do not include any leading plus or
+-- minus signs; this should be only digits and a decimal point.
+newtype Amount = Amount { unAmount :: Text }
+ deriving (Eq, Show, Ord, Read)
+
+instance S.Serialize Amount where
+ put = putText . unAmount
+ get = getText >>= f
+ where
+ f x = case mkAmount . unpack $ x of
+ Nothing -> fail $ "failed to load amount: " ++ unpack x
+ Just a -> return a
+
+-- | Ensures that incoming Amounts have only digits and (up to) one
+-- decimal point.
+mkAmount :: String -> Maybe Amount
+mkAmount s =
+ let isDigit c = c >= '0' && c <= '9'
+ (_, rs) = span isDigit s
+ in case rs of
+ "" -> if not . null $ s
+ then return . Amount . pack $ s
+ else Nothing
+ '.':rest -> if all isDigit rest
+ then return . Amount . pack $ s
+ else Nothing
+ _ -> Nothing
+
+translate
+ :: IncDec
+ -> Translator
+ -> L.DrCr
+translate Increase IncreaseIsDebit = L.Debit
+translate Increase IncreaseIsCredit = L.Credit
+translate Decrease IncreaseIsDebit = L.Credit
+translate Decrease IncreaseIsCredit = L.Debit
+
+type DbMap = M.Map UNumber Posting
+type DbList = [(UNumber, Posting)]
+
+data Posting = Posting
+ { date :: Date
+ , desc :: Desc
+ , incDec :: IncDec
+ , amount :: Amount
+ , payee :: Payee
+ , fitId :: FitId
+ } deriving (Read, Show)
+
+
+instance S.Serialize Posting where
+ put x = S.put (date x)
+ >> S.put (desc x)
+ >> S.put (incDec x)
+ >> S.put (amount x)
+ >> S.put (payee x)
+ >> S.put (fitId x)
+ get = Posting
+ <$> S.get
+ <*> S.get
+ <*> S.get
+ <*> S.get
+ <*> S.get
+ <*> S.get
+
+-- | Where is the database of postings?
+newtype DbLocation = DbLocation { unDbLocation :: Text }
+ deriving (Eq, Show)
+
+instance L.HasText DbLocation where text = unDbLocation
+
+-- | Text description of the financial institution account.
+newtype FitAcctDesc = FitAcctDesc { unFitAcctDesc :: Text }
+ deriving (Eq, Show)
+
+instance L.HasText FitAcctDesc where text = unFitAcctDesc
+
+-- | Text description of the parser itself.
+newtype ParserDesc = ParserDesc { unParserDesc :: Text }
+ deriving (Eq, Show)
+
+instance L.HasText ParserDesc where text = unParserDesc
+
+-- | A name used to refer to a batch of settings.
+newtype FitAcctName = FitAcctName { unFitAcctName :: Text }
+ deriving (Eq, Show)
+
+instance L.HasText FitAcctName where text = unFitAcctName
+
+-- | The Penny account holding postings for this financial
+-- institution. For instance it might be @Assets:Checking@ if this is
+-- your checking account, @Liabilities:Credit Card@, or whatever.
+newtype PennyAcct = PennyAcct { unPennyAcct :: L.Account }
+ deriving (Eq, Show)
+
+instance L.HasTextList PennyAcct where
+ textList = L.textList . unPennyAcct
+
+-- | What the financial institution shows as an increase or decrease
+-- has to be recorded as a debit or credit in the PennyAcct.
+data Translator
+ = IncreaseIsDebit
+ -- ^ That is, when the financial institution shows a posting that
+ -- increases your account balance, you record a debit. You will
+ -- probably use this for deposit accounts, like checking and
+ -- savings. These are asset accounts so if the balance goes up you
+ -- record a debit in your ledger.
+
+ | IncreaseIsCredit
+ -- ^ That is, when the financial institution shows a posting that
+ -- increases your account balance, you record a credit. You will
+ -- probably use this for liabilities, such as credit cards and other
+ -- loans.
+
+ deriving (Eq, Show)
+
+-- | The default account to place unclassified postings in. For
+-- instance @Expenses:Unclassified@.
+newtype DefaultAcct = DefaultAcct { unDefaultAcct :: L.Account }
+ deriving (Eq, Show)
+
+instance L.HasTextList DefaultAcct where
+ textList = L.textList . unDefaultAcct
+
+-- | The currency for all transactions, e.g. @$@.
+newtype Currency = Currency { unCurrency :: L.Commodity }
+ deriving (Eq, Show)
+
+instance L.HasText Currency where text = L.text . unCurrency
+
+-- | A batch of settings representing a single financial institution
+-- account.
+data FitAcct = FitAcct
+ { fitAcctName :: FitAcctName
+ , fitAcctDesc :: FitAcctDesc
+ , dbLocation :: DbLocation
+ , pennyAcct :: PennyAcct
+ , defaultAcct :: DefaultAcct
+ , currency :: Currency
+
+ , qtySpec :: Su.S3 L.Radix L.PeriodGrp L.CommaGrp
+ -- ^ How to turn Qty into QtyRep.
+
+ , translator :: Translator
+
+ , side :: L.Side
+ -- ^ When creating new transactions, the commodity will be on this
+ -- side
+
+ , spaceBetween :: L.SpaceBetween
+ -- ^ When creating new transactions, is there a space between the
+ -- commodity and the quantity
+
+ , parser :: ( ParserDesc
+ , FitFileLocation -> IO (Ex.Exceptional String [Posting]))
+ -- ^ Parses a file of transactions from the financial
+ -- institution. The function must open the file and parse it. This
+ -- is in the IO monad not only because the function must open the
+ -- file itself, but also so the function can perform arbitrary IO
+ -- (run pdftotext, maybe?) If there is failure, the function can
+ -- return an Exceptional String, which is the error
+ -- message. Alternatively the function can raise an exception in the
+ -- IO monad (currently Brenner makes no attempt to catch these) so
+ -- if any of the IO functions throw you can simply not handle the
+ -- exceptions.
+ --
+ -- The first element of the pair gives information about the parser.
+
+ , toLincolnPayee :: Desc -> Payee -> L.Payee
+ -- ^ Sometimes the financial institution provides Payee information,
+ -- sometimes it does not. Sometimes the Desc might have additional
+ -- information that you might want to remove. This function can be
+ -- used to do that. The resulting Lincoln Payee is used for any
+ -- transactions that are created by the merge command. The resulting
+ -- payee is also used when comparing new financial institution
+ -- postings to already existing ledger transactions in order to
+ -- guess at which payee and accounts to create in the transactions
+ -- created by the merge command.
+
+ }
+
+-- | Configuration for the Brenner program. You can optionally have
+-- a default FitAcct, which is used if you do not specify any FitAcct on the
+-- command line. You can also name any number of additional FitAccts. If
+-- you do not specify a default FitAcct, you must specify a FitAcct on the
+-- command line.
+
+data Config = Config
+ { defaultFitAcct :: Maybe FitAcct
+ , moreFitAccts :: [FitAcct]
+ }
+
+newtype FitFileLocation = FitFileLocation { unFitFileLocation :: String }
+ deriving (Show, Eq)
+
+newtype AllowNew = AllowNew { unAllowNew :: Bool }
+ deriving (Show, Eq)
+
+-- | All parsers must be of this type.
+type ParserFn
+ = FitFileLocation
+ -> IO (Ex.Exceptional String [Posting])
+
diff --git a/lib/Penny/Brenner/Util.hs b/lib/Penny/Brenner/Util.hs
new file mode 100644
index 0000000..62bad9e
--- /dev/null
+++ b/lib/Penny/Brenner/Util.hs
@@ -0,0 +1,106 @@
+module Penny.Brenner.Util where
+
+import Control.Monad.Exception.Synchronous as Ex
+import qualified Penny.Brenner.Types as Y
+import qualified Data.ByteString as BS
+import qualified System.IO.Error as IOE
+import qualified Data.Serialize as S
+import qualified Data.Text as X
+import qualified Penny.Copper.Parsec as CP
+import qualified Text.Parsec as P
+import qualified Penny.Lincoln as L
+import qualified System.Exit as Exit
+import qualified System.IO as IO
+import System.Environment (getProgName)
+
+-- | Print an error message and exit.
+errExit :: String -> IO a
+errExit s = do
+ pn <- getProgName
+ IO.hPutStrLn IO.stderr $ pn ++ ": error: " ++ s
+ Exit.exitFailure
+
+-- | Gets the FitAcct, if it was provided. If it was not provided,
+-- exit with an error message.
+getFitAcct :: Maybe Y.FitAcct -> IO Y.FitAcct
+getFitAcct ma = case ma of
+ Nothing -> errExit $ "no default financial institution account, "
+ ++ "and no financial institution account provided"
+ ++ " on command line."
+ Just a -> return a
+
+-- | Loads the database from disk. If allowNew is True, then does not
+-- fail if the file was not found.
+loadDb
+ :: Y.AllowNew
+ -- ^ Is a new file allowed?
+
+ -> Y.DbLocation
+ -- ^ DB location
+
+ -> IO Y.DbList
+loadDb (Y.AllowNew allowNew) (Y.DbLocation dbLoc) = do
+ eiStr <- IOE.tryIOError (BS.readFile . X.unpack $ dbLoc)
+ case eiStr of
+ Left e ->
+ if allowNew && IOE.isDoesNotExistError e
+ then return []
+ else IOE.ioError e
+ Right g -> case readDbTuple g of
+ Ex.Exception e -> fail e
+ Ex.Success good -> return good
+
+-- | File version. Increment this when anything in the file format
+-- changes.
+version :: Int
+version = 0
+
+brenner :: String
+brenner = "penny.brenner"
+
+readDbTuple
+ :: BS.ByteString
+ -> Ex.Exceptional String Y.DbList
+readDbTuple bs = do
+ (s, v, ls) <- Ex.fromEither $ S.decode bs
+ Ex.assert "database file format not recognized." $ s == brenner
+ Ex.assert "wrong database version." $ v == version
+ return ls
+
+saveDbTuple :: Y.DbList -> BS.ByteString
+saveDbTuple ls = S.encode (brenner, version, ls)
+
+-- | Writes a new database to disk.
+saveDb :: Y.DbLocation -> Y.DbList -> IO ()
+saveDb (Y.DbLocation p) = BS.writeFile (X.unpack p) . saveDbTuple
+
+-- | Parses quantities from amounts. All amounts should be verified as
+-- having only digits, optionally followed by a point and then more
+-- digits. All these values should parse. So if there is a problem it
+-- is a programmer error. Apply error.
+parseQty :: Y.Amount -> L.Qty
+parseQty a = case P.parse CP.unquotedQtyRep "" (Y.unAmount a) of
+ Left e -> error $ "could not parse quantity from string: "
+ ++ (X.unpack . Y.unAmount $ a) ++ ": " ++ show e
+ Right g -> L.toQty g
+
+label :: String -> X.Text -> String
+label s x = s ++ ": " ++ X.unpack x ++ "\n"
+
+-- | Shows a Posting in human readable format.
+showPosting :: Y.Posting -> String
+showPosting (Y.Posting dt dc nc am py fd) =
+ label "Date" (X.pack . show . Y.unDate $ dt)
+ ++ label "Description" (Y.unDesc dc)
+ ++ label "Type" (X.pack $ case nc of
+ Y.Increase -> "increase"
+ Y.Decrease -> "decrease")
+ ++ label "Amount" (Y.unAmount am)
+ ++ label "Payee" (Y.unPayee py)
+ ++ label "Financial institution ID" (Y.unFitId fd)
+ ++ "\n"
+
+showDbPair :: (Y.UNumber, Y.Posting) -> String
+showDbPair (Y.UNumber u, p) =
+ label "U number" (X.pack . show $ u)
+ ++ showPosting p
diff --git a/lib/Penny/Cabin.hs b/lib/Penny/Cabin.hs
new file mode 100644
index 0000000..d526967
--- /dev/null
+++ b/lib/Penny/Cabin.hs
@@ -0,0 +1,7 @@
+-- | Cabin - Penny reports
+--
+-- Cabin contains reports, or functions that take a list of postings
+-- and return a formatted Text to display data in a human-readable
+-- format.
+module Penny.Cabin where
+
diff --git a/lib/Penny/Cabin/Balance.hs b/lib/Penny/Cabin/Balance.hs
new file mode 100644
index 0000000..f89431b
--- /dev/null
+++ b/lib/Penny/Cabin/Balance.hs
@@ -0,0 +1,21 @@
+-- | Penny balance reports. Currently there are two balance reports:
+-- the MultiCommodity report, which cannot convert commodities and
+-- which therefore might show more than one commodity in a single
+-- report, and the Convert report, which uses price data in the Penny
+-- file to convert all commodities to a single commodity. The Convert
+-- report always displays only one commodity per account and this one
+-- commodity for the whole report.
+module Penny.Cabin.Balance where
+
+import qualified Penny.Cabin.Balance.MultiCommodity as MC
+import qualified Penny.Cabin.Interface as I
+import qualified Penny.Cabin.Balance.Convert as C
+import qualified Penny.Cabin.Balance.Convert.Options as ConvOpts
+
+-- | The default multi-commodity balance report.
+multiCommodity :: I.Report
+multiCommodity = MC.defaultReport
+
+-- | The default converting balance report.
+convert :: I.Report
+convert = C.cmdLineReport ConvOpts.defaultOptions
diff --git a/lib/Penny/Cabin/Balance/Convert.hs b/lib/Penny/Cabin/Balance/Convert.hs
new file mode 100644
index 0000000..7a08dab
--- /dev/null
+++ b/lib/Penny/Cabin/Balance/Convert.hs
@@ -0,0 +1,335 @@
+-- | The Convert report. This report converts all account balances to
+-- a single commodity, which must be specified.
+
+module Penny.Cabin.Balance.Convert (
+ Opts(..)
+ , Sorter
+ , report
+ , cmdLineReport
+ , getSorter
+ ) where
+
+import Control.Applicative ((<$>), (<*>))
+import qualified Control.Monad.Exception.Synchronous as Ex
+import qualified Data.Tree as E
+import qualified Data.Traversable as Tvbl
+import qualified Penny.Cabin.Options as CO
+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.Options as O
+import qualified Penny.Cabin.Balance.Convert.Parser as P
+import qualified Penny.Cabin.Interface as I
+import qualified Penny.Lincoln as L
+import qualified Penny.Lincoln.Balance as Bal
+import qualified Penny.Liberty as Ly
+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 qualified System.Console.MultiArg as MA
+import qualified System.Console.Rainbow as Rb
+
+-- | Options for the Convert report. These are the only options you
+-- 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
+ , showZeroBalances :: CO.ShowZeroBalances
+ , sorter :: Sorter
+ , target :: L.To
+ , dateTime :: L.DateTime
+ , textFormats :: Scheme.Changers
+ }
+
+-- | How to sort each line of the report. Each subaccount has only one
+-- BottomLine (unlike in the MultiCommodity report, where each
+-- subaccount may have more than one BottomLine, one for each
+-- commodity.)
+type Sorter
+ = (L.SubAccount, L.BottomLine)
+ -> (L.SubAccount, L.BottomLine)
+ -> Ordering
+
+-- | Converts all commodities in a Balance to a single commodity and
+-- combines all the BottomLines into one. Fails with an error message
+-- if no conversion data is available.
+convertBalance
+ :: L.PriceDb
+ -> L.DateTime
+ -> L.To
+ -> L.Balance
+ -> Ex.Exceptional X.Text L.BottomLine
+convertBalance db dt to bal = fmap mconcat r
+ where
+ r = mapM (convertOne db dt to) . M.assocs . L.unBalance $ bal
+
+-- | Converts a single BottomLine to a new commodity. Fails with an
+-- error message if no conversion data is available.
+convertOne
+ :: L.PriceDb
+ -> L.DateTime
+ -> L.To
+ -> (L.Commodity, L.BottomLine)
+ -> Ex.Exceptional X.Text L.BottomLine
+convertOne db dt to (cty, bl) =
+ case bl of
+ L.Zero -> return L.Zero
+ L.NonZero (L.Column dc qt) -> Ex.mapExceptional e g ex
+ where
+ ex = L.convertAsOf db dt to am
+ am = L.Amount qt cty
+ e = convertError to (L.From cty)
+ g r = L.NonZero (L.Column dc r)
+
+-- | Creates an error message for conversion errors.
+convertError
+ :: L.To
+ -> L.From
+ -> L.PriceDbError
+ -> X.Text
+convertError (L.To to) (L.From fr) e =
+ let fromErr = L.unCommodity fr
+ toErr = L.unCommodity to
+ in case e of
+ L.FromNotFound ->
+ X.pack "no data to convert from commodity "
+ `X.append` fromErr
+ L.ToNotFound ->
+ X.pack "no data to convert to commodity "
+ `X.append` toErr
+ L.CpuNotFound ->
+ X.pack "no data to convert from commodity "
+ `X.append` fromErr
+ `X.append` (X.pack " to commodity ")
+ `X.append` toErr
+ `X.append` (X.pack " at given date and time")
+
+
+-- | Create a price database.
+buildDb :: [L.PricePoint] -> L.PriceDb
+buildDb = foldl f L.emptyDb where
+ f db pb = L.addPrice db pb
+
+-- | All data for the report after all balances have been converted to
+-- a single commodity and all the sums of the child accounts have been
+-- added to the parent accounts.
+data ForestAndBL = ForestAndBL {
+ _tbForest :: E.Forest (L.SubAccount, L.BottomLine)
+ , _tbTotal :: L.BottomLine
+ , _tbTo :: L.To
+ }
+
+-- | Converts the balance data in preparation for screen rendering.
+rows :: ForestAndBL -> ([K.Row], L.To)
+rows (ForestAndBL f tot to) = (first:second:rest, to)
+ where
+ first = K.ROneCol $ K.OneColRow 0 desc
+ desc = X.pack "All amounts reported in commodity: "
+ `X.append` (L.unCommodity
+ . L.unTo
+ $ to)
+ second = K.RMain $ K.MainRow 0 (X.pack "Total") tot
+ rest = map mainRow
+ . concatMap E.flatten
+ . map U.labelLevels
+ $ f
+
+
+mainRow :: (Int, (L.SubAccount, L.BottomLine)) -> K.Row
+mainRow (l, (a, b)) = K.RMain $ K.MainRow l x b
+ where
+ x = L.text a
+
+-- | The function for the Convert report. Use this function if you are
+-- setting the options from a program (as opposed to parsing them in
+-- from the command line.) Will fail if the balance conversions fail.
+report
+ :: Opts
+ -> [L.PricePoint]
+ -> [(a, L.Posting)]
+ -> Ex.Exceptional X.Text [Rb.Chunk]
+report os@(Opts getFmt _ _ _ _ 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
+
+
+-- | Creates a report respecting the standard interface for reports
+-- whose options are parsed in from the command line.
+cmdLineReport
+ :: O.DefaultOpts
+ -> I.Report
+cmdLineReport o rt = (help o, mkMode)
+ where
+ mkMode _ _ chgrs _ fsf = MA.modeHelp
+ "convert"
+ (const (help o))
+ (process rt chgrs o fsf)
+ (map (fmap Right) P.allOptSpecs)
+ MA.Intersperse
+ (return . Left)
+
+
+process
+ :: S.Runtime
+ -> 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
+ 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)
+
+
+-- | Sums the balances from the bottom to the top of the tree (so that
+-- parent accounts have the sum of the balances of all their
+-- children.) Then converts the commodities to a single commodity, and
+-- sorts the accounts as requested. Fails if the conversion fails.
+sumConvertSort
+ :: Opts
+ -> [L.PricePoint]
+ -> [(a, L.Posting)]
+ -> Ex.Exceptional X.Text ForestAndBL
+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
+ 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
+ mkResult f t = ForestAndBL (U.sortForest str f) t tgt
+
+-- | Determine the most frequent To commodity.
+mostFrequent :: [L.PricePoint] -> Maybe L.To
+mostFrequent = U.lastMode . map (L.to . L.price)
+
+
+type DoReport
+ = [L.PricePoint]
+ -> (L.Amount L.Qty -> X.Text)
+ -> (Maybe Opts)
+
+-- | Get options for the report, depending on what options were parsed
+-- from the command line. Fails if the user did not specify a
+-- commodity and mostFrequent fails.
+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
+
+-- | Returns a function usable to sort pairs of SubAccount and
+-- BottomLine depending on how you want them sorted.
+getSorter :: CP.SortOrder -> P.SortBy -> Sorter
+getSorter o b = flipper f
+ where
+ flipper = case o of
+ CP.Ascending -> id
+ CP.Descending ->
+ \g p1 p2 -> case g p1 p2 of
+ LT -> GT
+ GT -> LT
+ EQ -> EQ
+ f p1@(a1, _) p2@(a2, _) = case b of
+ P.SortByName -> compare a1 a2
+ P.SortByQty -> cmpBottomLine p1 p2
+
+cmpBottomLine :: Sorter
+cmpBottomLine (n1, bl1) (n2, bl2) =
+ case (bl1, bl2) of
+ (L.Zero, L.Zero) -> EQ
+ (L.NonZero _, L.Zero) -> LT
+ (L.Zero, L.NonZero _) -> GT
+ (L.NonZero c1, L.NonZero c2) ->
+ mconcat [dc, qt, na]
+ where
+ dc = case (Bal.colDrCr c1, Bal.colDrCr c2) of
+ (L.Debit, L.Debit) -> EQ
+ (L.Debit, L.Credit) -> LT
+ (L.Credit, L.Debit) -> GT
+ (L.Credit, L.Credit) -> EQ
+ qt = compare (Bal.colQty c1) (Bal.colQty c2)
+ na = compare n1 n2
+
+------------------------------------------------------------
+-- ## Help
+------------------------------------------------------------
+ifDefault :: Bool -> String
+ifDefault b = if b then " (default)" else ""
+
+help :: O.DefaultOpts -> String
+help o = unlines $
+ [ "convert"
+ , " Show account balances, after converting all amounts"
+ , " to a single commodity. Accepts ONLY the following options:"
+ , ""
+ , "--show-zero-balances"
+ , " Show balances that are zero"
+ ++ ifDefault (CO.unShowZeroBalances . O.showZeroBalances $ o)
+ , "--hide-zero-balances"
+ , " Hide balances that are zero"
+ ++ ifDefault (not . CO.unShowZeroBalances . O.showZeroBalances $ o)
+ , ""
+ , "--commodity TARGET-COMMMODITY, -c TARGET-COMMODITY"
+ , " Convert all commodities to TARGET-COMMODITY."
+ ] ++ case O.target o of
+ P.ManualTarget (L.To cy) ->
+ [ " default: " ++ (X.unpack . L.unCommodity $ cy) ]
+ _ -> []
+ ++
+ [ "--auto-commodity"
+ , " convert all commodities to the commodity that appears most"
+ , " often as the target commodity in your price data. If"
+ , " there is a tie, the price closest to the end of your list"
+ , " of prices is used."
+ ++ case O.target o of
+ P.AutoTarget -> " (default)"
+ _ -> ""
+ , ""
+ , "--date DATE-TIME, -d DATE-TIME"
+ , " Convert prices as of the date and time given"
+ , " (by default, the current date and time is used.)"
+ , ""
+ , "--sort qty|name, -s qty|name"
+ , " Sort balances by sub-account name"
+ ++ 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)
+ , ""
+ , "--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
new file mode 100644
index 0000000..102cd64
--- /dev/null
+++ b/lib/Penny/Cabin/Balance/Convert/Chunker.hs
@@ -0,0 +1,240 @@
+-- | Creates the output Chunks for the Balance report for
+-- multi-commodity reports only.
+
+module Penny.Cabin.Balance.Convert.Chunker (
+ MainRow(..),
+ OneColRow(..),
+ Row(..),
+ 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
+
+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
+ }
+
+-- | 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
+
+ , mrBottomLine :: L.BottomLine
+ -- ^ Commodity balances. If this list is empty, dashes are
+ -- displayed for the DrCr and Qty.
+ }
+
+
+rowsToChunks
+ :: E.Changers
+ -> (L.Qty -> X.Text)
+ -- ^ How to format a balance to allow for digit grouping
+ -> [Row]
+ -> [Rb.Chunk]
+rowsToChunks chgrs fmt =
+ preSpecsToBits chgrs
+ . rowsToColumns chgrs fmt
+
+rowsToColumns
+ :: E.Changers
+ -> (L.Qty -> X.Text)
+ -- ^ How to format a balance to allow for digit grouping
+
+ -> [Row]
+ -> [Columns PreSpec]
+rowsToColumns chgrs fmt
+ = map (mkRow chgrs fmt)
+ . L.serialItems (\ser r -> (Meta.VisibleNum ser, r))
+
+
+mkRow
+ :: E.Changers
+ -> (L.Qty -> X.Text)
+ -> (Meta.VisibleNum, Row)
+ -> Columns PreSpec
+mkRow chgrs fmt (vn, r) = case r of
+ RMain m -> mkMainRow chgrs fmt (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
+ -> (L.Qty -> X.Text)
+ -> (Meta.VisibleNum, MainRow)
+ -> Columns PreSpec
+mkMainRow chgrs fmt (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 fmt vn b
+
+
+balanceChunks
+ :: E.Changers
+ -> (L.Qty -> X.Text)
+ -> Meta.VisibleNum
+ -> L.BottomLine
+ -> (Rb.Chunk, Rb.Chunk)
+balanceChunks chgrs fmt vn bl = (chkDc, chkQt)
+ where
+ eo = E.fromVisibleNum vn
+ chkDc = E.bottomLineToDrCr bl eo chgrs
+ qtFmt = E.getEvenOddLabelValue lbl eo chgrs
+ chkQt = qtFmt $ Rb.Chunk mempty t
+ (lbl, t) = case bl of
+ L.Zero -> (E.Zero, X.pack "--")
+ L.NonZero (L.Column dc qt) -> (E.dcToLbl dc, fmt qt)
+
+
+indentAmount :: Int
+indentAmount = 2
+
diff --git a/lib/Penny/Cabin/Balance/Convert/Options.hs b/lib/Penny/Cabin/Balance/Convert/Options.hs
new file mode 100644
index 0000000..b7d0ee1
--- /dev/null
+++ b/lib/Penny/Cabin/Balance/Convert/Options.hs
@@ -0,0 +1,39 @@
+-- | Default options for the Convert report when used from the command
+-- line.
+module Penny.Cabin.Balance.Convert.Options where
+
+import qualified Penny.Cabin.Balance.Convert.Parser as P
+import qualified Penny.Cabin.Parsers as CP
+import qualified Penny.Cabin.Options as CO
+import qualified Penny.Shield as S
+
+-- | Default options for the Convert report. This record is used as
+-- the starting point when parsing in options from the command
+-- line. You don't need to use it if you are setting the options for
+-- the Convert report directly from your own code.
+
+data DefaultOpts = DefaultOpts
+ { showZeroBalances :: CO.ShowZeroBalances
+ , target :: P.Target
+ , sortOrder :: CP.SortOrder
+ , sortBy :: P.SortBy
+ }
+
+toParserOpts :: DefaultOpts -> S.Runtime -> P.Opts
+toParserOpts d rt = P.Opts
+ { P.showZeroBalances = showZeroBalances d
+ , P.target = target d
+ , P.dateTime = S.currentTime rt
+ , P.sortOrder = sortOrder d
+ , P.sortBy = sortBy d
+ }
+
+defaultOptions :: DefaultOpts
+defaultOptions = DefaultOpts
+ { showZeroBalances = CO.ShowZeroBalances False
+ , target = P.AutoTarget
+ , sortOrder = CP.Ascending
+ , sortBy = P.SortByName
+ }
+
+
diff --git a/lib/Penny/Cabin/Balance/Convert/Parser.hs b/lib/Penny/Cabin/Balance/Convert/Parser.hs
new file mode 100644
index 0000000..465cf73
--- /dev/null
+++ b/lib/Penny/Cabin/Balance/Convert/Parser.hs
@@ -0,0 +1,87 @@
+-- | Parsing options for the Convert report from the command line.
+module Penny.Cabin.Balance.Convert.Parser (
+ Opts(..)
+ , Target(..)
+ , SortBy(..)
+ , allOptSpecs
+ ) where
+
+
+import qualified Control.Monad.Exception.Synchronous as Ex
+import qualified Data.Text as X
+import qualified Penny.Cabin.Options as CO
+import qualified Penny.Cabin.Parsers as P
+import qualified Penny.Lincoln as L
+import qualified Penny.Copper.Parsec as Pc
+import qualified System.Console.MultiArg.Combinator as C
+import qualified Text.Parsec as Parsec
+
+
+-- | Is the target commodity determined by the user or automatically?
+data Target = AutoTarget | ManualTarget L.To
+
+data SortBy = SortByQty | SortByName deriving (Eq, Show, Ord)
+
+-- | Default starting options for the Convert report. After
+-- considering what is parsed in from the command line and price data,
+-- a Convert.Opts will be generated.
+data Opts = Opts
+ { showZeroBalances :: CO.ShowZeroBalances
+ , target :: Target
+ , dateTime :: L.DateTime
+ , sortOrder :: P.SortOrder
+ , sortBy :: SortBy
+ }
+
+-- | 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 =
+ [ fmap toExc parseZeroBalances
+ , parseCommodity
+ , fmap toExc parseAuto
+ , parseDate
+ , fmap toExc parseSort
+ , fmap toExc parseOrder ]
+ where
+ toExc f = return . f
+
+parseZeroBalances :: C.OptSpec (Opts -> Opts)
+parseZeroBalances = fmap f P.zeroBalances
+ where
+ f x o = o { showZeroBalances = x }
+
+
+parseCommodity :: C.OptSpec (Opts -> Ex.Exceptional String Opts)
+parseCommodity = C.OptSpec ["commodity"] "c" (C.OneArg f)
+ where
+ f a1 os =
+ case Parsec.parse Pc.lvl1Cmdty "" (X.pack a1) of
+ Left _ -> Ex.throw $ "invalid commodity: " ++ a1
+ Right g -> return $ 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)
+ where
+ f a1 os =
+ case Parsec.parse Pc.dateTime "" (X.pack a1) of
+ Left _ -> Ex.throw $ "invalid date: " ++ a1
+ Right g -> return $ os { dateTime = g }
+
+parseSort :: C.OptSpec (Opts -> Opts)
+parseSort = C.OptSpec ["sort"] "s" (C.ChoiceArg ls)
+ where
+ ls = [ ("qty", (\os -> os { sortBy = SortByQty }))
+ , ("name", (\os -> os { sortBy = SortByName })) ]
+
+parseOrder :: C.OptSpec (Opts -> Opts)
+parseOrder = fmap f P.order
+ where
+ f x o = o { sortOrder = x }
diff --git a/lib/Penny/Cabin/Balance/MultiCommodity.hs b/lib/Penny/Cabin/Balance/MultiCommodity.hs
new file mode 100644
index 0000000..6a5e69f
--- /dev/null
+++ b/lib/Penny/Cabin/Balance/MultiCommodity.hs
@@ -0,0 +1,168 @@
+-- | The multi-commodity Balance report. This is the simpler balance
+-- report because it does not allow for commodities to be converted.
+
+module Penny.Cabin.Balance.MultiCommodity (
+ Opts(..),
+ defaultOpts,
+ defaultParseOpts,
+ parseReport,
+ defaultReport,
+ report
+ ) where
+
+import Control.Applicative (Applicative, pure)
+import qualified Penny.Cabin.Balance.Util as U
+import qualified Penny.Cabin.Scheme as E
+import qualified Penny.Cabin.Scheme.Schemes as Schemes
+import qualified Penny.Lincoln as L
+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 qualified Data.Text as X
+import qualified Data.Tree as E
+import qualified Penny.Cabin.Balance.MultiCommodity.Chunker as K
+import qualified Penny.Cabin.Balance.MultiCommodity.Parser as P
+import qualified Penny.Cabin.Interface as I
+import qualified Penny.Cabin.Parsers as CP
+import qualified System.Console.MultiArg as MA
+import qualified System.Console.Rainbow as R
+
+-- | Options for making the balance report. These are the only options
+-- needed to make the report if the options are not being parsed in
+-- from the command line.
+data Opts = Opts
+ { balanceFormat :: L.Amount L.Qty -> X.Text
+ , showZeroBalances :: CO.ShowZeroBalances
+ , order :: L.SubAccount -> L.SubAccount -> Ordering
+ , textFormats :: E.Changers
+ }
+
+defaultOpts :: (L.Amount L.Qty -> X.Text) -> Opts
+defaultOpts fmt = Opts
+ { balanceFormat = fmt
+ , showZeroBalances = CO.ShowZeroBalances True
+ , order = compare
+ , textFormats = Schemes.darkLabels
+ }
+
+defaultParseOpts :: P.ParseOpts
+defaultParseOpts = P.ParseOpts
+ { P.showZeroBalances = CO.ShowZeroBalances False
+ , P.order = CP.Ascending
+ }
+
+fromParseOpts
+ :: E.Changers
+ -> (L.Amount L.Qty -> X.Text)
+ -> P.ParseOpts
+ -> Opts
+fromParseOpts chgrs fmt (P.ParseOpts szb o) = Opts fmt szb o' chgrs
+ where
+ o' = case o of
+ CP.Ascending -> compare
+ CP.Descending -> CO.descending compare
+
+summedSortedBalTree ::
+ CO.ShowZeroBalances
+ -> (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
+ where
+ o' x y = o (fst x) (fst y)
+
+rows ::
+ (E.Forest (L.SubAccount, L.Balance), L.Balance)
+ -> [K.Row]
+rows (o, b) = first:rest
+ where
+ first = K.Row 0 (X.pack "Total") (M.assocs . L.unBalance $ b)
+ rest = map row . concatMap E.flatten . map U.labelLevels $ o
+ row (l, (s, ib)) =
+ K.Row l (L.text s) (M.assocs . L.unBalance $ ib)
+
+-- | This report is what to use if you already have your options (that
+-- is, you are not parsing them in from the command line.)
+report :: Opts -> [(a, L.Posting)] -> [R.Chunk]
+report (Opts bf szb o chgrs) =
+ K.rowsToChunks chgrs bf
+ . rows
+ . summedSortedBalTree szb o
+
+-- | The MultiCommodity report with configurable options that have
+-- been parsed from the command line.
+parseReport
+ :: P.ParseOpts
+ -- ^ Default options for the report. These can be overriden on the
+ -- command line.
+
+ -> I.Report
+parseReport o rt = (help o, makeMode)
+ where
+ makeMode _ _ chgrs _ fsf = MA.modeHelp
+ "balance"
+ (const (help o))
+ (process chgrs o rt fsf)
+ (map (fmap Right) P.allSpecs)
+ MA.Intersperse
+ (return . Left)
+
+process
+ :: Applicative f
+ => E.Changers
+ -> P.ParseOpts
+ -> a
+ -> ([L.Transaction] -> [(Ly.LibertyMeta, L.Posting)])
+ -> [Either String (P.ParseOpts -> P.ParseOpts)]
+ -> f I.ArgsAndReport
+process chgrs o _ fsf ls =
+ let (posArgs, fns) = Ei.partitionEithers ls
+ mkParsedOpts = foldl (flip (.)) id fns
+ os' = mkParsedOpts o
+ pr fmt txns _ = return $ report mcOpts (fsf txns)
+ where
+ mcOpts = fromParseOpts chgrs fmt os'
+ in pure (posArgs, pr)
+
+
+-- | The MultiCommodity report, with default options.
+defaultReport :: I.Report
+defaultReport = parseReport defaultParseOpts
+
+------------------------------------------------------------
+-- ## Help
+------------------------------------------------------------
+ifDefault :: Bool -> String
+ifDefault b = if b then " (default)" else ""
+
+help :: P.ParseOpts -> String
+help o = unlines
+ [ "balance"
+ , " Show account balances. Accepts ONLY the following options:"
+ , ""
+ , "--show-zero-balances"
+ , " Show balances that are zero"
+ ++ ifDefault (CO.unShowZeroBalances . P.showZeroBalances $ o)
+ , "--hide-zero-balances"
+ , " Hide balances that are zero"
+ ++ 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)
+
+ , ""
+ , "--help, -h"
+ , " Show this help and exit"
+ ]
+
diff --git a/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs b/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs
new file mode 100644
index 0000000..59bcf8e
--- /dev/null
+++ b/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs
@@ -0,0 +1,224 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Creates the output Chunks for the Balance report for both
+-- multi-commodity reports.
+
+module Penny.Cabin.Balance.MultiCommodity.Chunker (
+ Row(..),
+ rowsToChunks
+ ) where
+
+
+import Control.Applicative
+ (Applicative (pure), (<$>), (<*>))
+import qualified Penny.Cabin.Meta as Meta
+import qualified Penny.Cabin.Row as R
+import qualified Penny.Cabin.Scheme as E
+import qualified Penny.Lincoln as L
+import Data.Monoid (mempty)
+import qualified Data.Foldable as Fdbl
+import qualified Data.Text as X
+import qualified System.Console.Rainbow as Rb
+
+type IsEven = Bool
+
+data Columns a = Columns {
+ acct :: a
+ , drCr :: a
+ , commodity :: a
+ , quantity :: a
+ } deriving Show
+
+instance Functor Columns where
+ fmap f c = Columns {
+ acct = f (acct c)
+ , drCr = f (drCr c)
+ , commodity = f (commodity c)
+ , quantity = f (quantity c)
+ }
+
+instance Applicative Columns where
+ pure a = Columns a a a a
+ fn <*> fa = Columns {
+ acct = (acct fn) (acct fa)
+ , drCr = (drCr fn) (drCr fa)
+ , commodity = (commodity fn) (commodity 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 ( safeMaximum (R.Width 0)
+ . map (R.Width . X.length . Rb._text)
+ . bits $ new)
+ safeMaximum d ls = if null ls then d else maximum ls
+
+-- | 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
+
+
+-- Step 9
+widthSpacerAcct :: Int
+widthSpacerAcct = 4
+
+widthSpacerDrCr :: Int
+widthSpacerDrCr = 1
+
+widthSpacerCommodity :: Int
+widthSpacerCommodity = 1
+
+colsToBits
+ :: E.Changers
+ -> IsEven
+ -> Columns R.ColumnSpec
+ -> [Rb.Chunk]
+colsToBits chgrs isEven (Columns a dc c 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
+ : c
+ : spacer widthSpacerCommodity
+ : 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
+
+-- | 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 Row = Row
+ { indentation :: 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)
+
+ , accountTxt :: X.Text
+ -- ^ Text for the name of the account
+
+ , balances :: [(L.Commodity, L.BottomLine)]
+ -- ^ Commodity balances. If this list is empty, dashes are
+ -- displayed for the DrCr, Commodity, and Qty.
+ }
+
+rowsToChunks
+ :: E.Changers
+ -> (L.Amount L.Qty -> X.Text)
+ -- ^ How to format a balance to allow for digit grouping
+ -> [Row]
+ -> [Rb.Chunk]
+rowsToChunks chgrs fmt =
+ preSpecsToBits chgrs
+ . rowsToColumns chgrs fmt
+
+rowsToColumns
+ :: E.Changers
+ -> (L.Amount L.Qty -> X.Text)
+ -- ^ How to format a balance to allow for digit grouping
+
+ -> [Row]
+ -> [Columns PreSpec]
+rowsToColumns chgrs fmt
+ = map (mkColumn chgrs fmt)
+ . L.serialItems (\ser a -> (Meta.VisibleNum ser, a))
+
+
+mkColumn
+ :: E.Changers
+ -> (L.Amount L.Qty -> X.Text)
+ -> (Meta.VisibleNum, Row)
+ -> Columns PreSpec
+mkColumn chgrs fmt (vn, (Row i acctTxt bs)) = Columns ca cd cc cq
+ where
+ lbl = E.Other
+ eo = E.fromVisibleNum vn
+ applyFmt = E.getEvenOddLabelValue lbl eo chgrs
+ 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) cksDrCr
+ cc = PreSpec R.RightJustify (lbl, eo) cksCmdty
+ cq = PreSpec R.LeftJustify (lbl, eo) cksQty
+ (cksDrCr, cksCmdty, cksQty) =
+ if null bs
+ then balanceChunksEmpty chgrs eo
+ else
+ let balChks = map (balanceChunks chgrs fmt eo) bs
+ cDrCr = map (\(a, _, _) -> a) balChks
+ cCmdty = map (\(_, a, _) -> a) balChks
+ cQty = map (\(_, _, a) -> a) balChks
+ in (cDrCr, cCmdty, cQty)
+
+
+balanceChunksEmpty
+ :: E.Changers
+ -> E.EvenOdd
+ -> ([Rb.Chunk], [Rb.Chunk], [Rb.Chunk])
+balanceChunksEmpty chgrs eo = (dash, dash, dash)
+ where
+ dash = [E.getEvenOddLabelValue E.Other eo chgrs $ "--"]
+
+balanceChunks
+ :: E.Changers
+ -> (L.Amount L.Qty -> X.Text)
+ -> E.EvenOdd
+ -> (L.Commodity, L.BottomLine)
+ -> (Rb.Chunk, Rb.Chunk, Rb.Chunk)
+balanceChunks chgrs fmt eo (cty, bl) = (chkDc, chkCt, chkQt)
+ where
+ chkDc = E.bottomLineToDrCr bl eo chgrs
+ chkCt = E.bottomLineToCmdty chgrs eo (cty, bl)
+ chkQt = E.bottomLineToQty chgrs fmt eo (cty, bl)
+
+
+indentAmount :: Int
+indentAmount = 2
+
diff --git a/lib/Penny/Cabin/Balance/MultiCommodity/Parser.hs b/lib/Penny/Cabin/Balance/MultiCommodity/Parser.hs
new file mode 100644
index 0000000..a751ddd
--- /dev/null
+++ b/lib/Penny/Cabin/Balance/MultiCommodity/Parser.hs
@@ -0,0 +1,29 @@
+module Penny.Cabin.Balance.MultiCommodity.Parser (
+ ParseOpts(..)
+ , allSpecs
+ ) where
+
+import qualified Penny.Cabin.Options as CO
+import qualified Penny.Cabin.Parsers as P
+import qualified System.Console.MultiArg as MA
+
+-- | Options for the Balance report that have been parsed from the
+-- command line.
+data ParseOpts = ParseOpts
+ { showZeroBalances :: CO.ShowZeroBalances
+ , order :: P.SortOrder
+ }
+
+
+zeroBalances :: MA.OptSpec (ParseOpts -> ParseOpts)
+zeroBalances = fmap toResult P.zeroBalances
+ where
+ toResult szb o = o { showZeroBalances = szb }
+
+parseOrder :: MA.OptSpec (ParseOpts -> ParseOpts)
+parseOrder = fmap toResult P.order
+ where
+ toResult x o = o { order = x }
+
+allSpecs :: [MA.OptSpec (ParseOpts -> ParseOpts)]
+allSpecs = [zeroBalances, parseOrder]
diff --git a/lib/Penny/Cabin/Balance/Util.hs b/lib/Penny/Cabin/Balance/Util.hs
new file mode 100644
index 0000000..42d7988
--- /dev/null
+++ b/lib/Penny/Cabin/Balance/Util.hs
@@ -0,0 +1,233 @@
+-- | Grab bag of utility functions.
+
+module Penny.Cabin.Balance.Util
+ ( tieredForest
+ , tieredPostings
+ , filterForest
+ , balances
+ , flatten
+ , treeWithParents
+ , forestWithParents
+ , sumForest
+ , sumTree
+ , boxesBalance
+ , labelLevels
+ , sortForest
+ , sortTree
+ , lastMode
+ ) where
+
+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 qualified Data.Map as M
+import Data.Ord (comparing)
+import Data.List (sortBy, maximumBy, groupBy)
+import Data.Monoid (mconcat, Monoid)
+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
+ where
+ e = Fdbl.toList . 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
+-- child tree is retained, does not delete the parent tree.
+filterForest :: (a -> Bool) -> T.Forest a -> T.Forest a
+filterForest f = mapMaybe pruneTree
+ where
+ pruneTree (T.Node a fs) =
+ case filterForest f fs of
+ [] -> if not (f a) then Nothing else Just (T.Node a [])
+ cs -> Just (T.Node a cs)
+
+
+-- | 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
+ -> [(a, L.Posting)]
+ -> T.Forest (L.SubAccount, L.Balance)
+balances (CO.ShowZeroBalances szb) =
+ remover
+ . map (fmap (mapSnd boxesBalance))
+ . tieredPostings
+ where
+ remover =
+ if szb
+ then id
+ else filterForest (not . M.null . L.unBalance . snd)
+ . map (fmap (mapSnd 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.
+flatten
+ :: T.Forest (L.SubAccount, L.Balance)
+ -> [(L.Account, L.Balance)]
+flatten =
+ concatMap T.flatten
+ . map (fmap toPair) . forestWithParents
+ where
+ toPair ((s, b), ls) =
+ case reverse . map fst $ ls of
+ [] -> (L.Account [s], b)
+ s1:sr -> (L.Account (s1 : (sr ++ [s])), b)
+
+-- | Takes a Tree and returns a Tree where each node has information
+-- about its parent Nodes. The list of parent nodes has the most
+-- immediate parent first and the most distant parent last.
+treeWithParents :: T.Tree a -> T.Tree (a, [a])
+treeWithParents = treeWithParentsR []
+
+-- | Given a list of the parents seen so far, return a Tree where each
+-- node contains information about its parents.
+treeWithParentsR :: [a] -> T.Tree a -> T.Tree (a, [a])
+treeWithParentsR ls (T.Node n cs) = T.Node (n, ls) cs'
+ where
+ cs' = map (treeWithParentsR (n:ls)) cs
+
+-- | Takes a Forest and returns a Forest where each node has
+-- information about its parent Nodes.
+forestWithParents :: T.Forest a -> T.Forest (a, [a])
+forestWithParents = map (treeWithParentsR [])
+
+-- | Sums a forest from the bottom up. Returns a pair, where the first
+-- 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)
+ -> (T.Forest (a, s), s)
+sumForest z f ts = (ts', s)
+ where
+ ts' = map (sumTree z f) ts
+ s = foldr f z . map (snd . T.rootLabel) $ ts'
+
+-- | Sums a tree from the bottom up.
+sumTree ::
+ s
+ -- ^ Zero
+
+ -> (s -> s -> s)
+ -- ^ Combiner
+
+ -> T.Tree (a, s)
+ -> T.Tree (a, s)
+sumTree z f (T.Node (a, s) cs) = T.Node (a, f s cSum) cs'
+ where
+ (cs', cSum) = sumForest z f cs
+
+
+boxesBalance :: [(a, L.Posting)] -> L.Balance
+boxesBalance
+ = mconcat
+ . map (either L.entryToBalance L.entryToBalance)
+ . 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)
+labelLevels = go 0
+ where
+ go l (T.Node x xs) = T.Node (l, x) (map (go (l + 1)) xs)
+
+-- | Sorts each level of a Forest.
+sortForest ::
+ (a -> a -> Ordering)
+ -> T.Forest a
+ -> T.Forest a
+sortForest o f = sortBy o' (map (sortTree o) f)
+ where
+ o' x y = o (T.rootLabel x) (T.rootLabel y)
+
+-- | Sorts each level of a Tree.
+sortTree ::
+ (a -> a -> Ordering)
+ -> T.Tree a
+ -> T.Tree a
+sortTree o (T.Node l f) = T.Node l (sortForest o f)
+
+-- | Like lastModeBy but using Ord.
+lastMode :: Ord a => [a] -> Maybe a
+lastMode = lastModeBy compare
+
+-- | Finds the mode of a list. Takes the mode that is located last in
+-- the list. Returns Nothing if there is no mode (that is, if the list
+-- is empty).
+lastModeBy ::
+ (a -> a -> Ordering)
+ -> [a]
+ -> Maybe a
+lastModeBy o ls =
+ case modesBy o' ls' of
+ [] -> Nothing
+ ms -> Just . fst . maximumBy fx $ ms
+ where
+ fx = comparing snd
+ ls' = zip ls ([0..] :: [Int])
+ o' x y = o (fst x) (fst y)
+
+-- | Finds the modes of a list.
+modesBy :: (a -> a -> Ordering) -> [a] -> [a]
+modesBy o =
+ concat
+ . longestLists
+ . groupBy (\x y -> o x y == EQ)
+ . sortBy o
+
+
+-- | Returns the longest lists. This function is partial. It is bottom
+-- if the argument list is empty. Therefore, do not export this
+-- function.
+longestLists :: [[a]] -> [[a]]
+longestLists as =
+ let lengths = map (\ls -> (ls, length ls)) as
+ maxLen = maximum . map snd $ lengths
+ in map fst . filter (\(_, len) -> len == maxLen) $ lengths
diff --git a/lib/Penny/Cabin/Interface.hs b/lib/Penny/Cabin/Interface.hs
new file mode 100644
index 0000000..e961033
--- /dev/null
+++ b/lib/Penny/Cabin/Interface.hs
@@ -0,0 +1,84 @@
+-- | An interface for other Penny components to use. A report is
+-- anything that is a 'Report'.
+module Penny.Cabin.Interface where
+
+import qualified Data.Prednote.Expressions as Exp
+import qualified Penny.Cabin.Scheme as S
+import Control.Monad.Exception.Synchronous (Exceptional)
+import qualified Data.Text as X
+import Text.Matchers (CaseSensitive)
+import qualified Text.Matchers as TM
+import qualified System.Console.MultiArg as MA
+import qualified System.Console.Rainbow as R
+
+import qualified Penny.Lincoln as L
+import qualified Penny.Liberty as Ly
+import Penny.Shield (Runtime)
+
+-- | The function that will print the report, and the positional
+-- arguments. If there was a problem parsing the command line options,
+-- return an Exception with an error message.
+
+-- | Parsing the filter options can have one of two results: a help
+-- string, or a list of positional arguments and a function that
+-- prints a report. Or, the parse might fail.
+
+type PosArg = String
+type HelpStr = String
+type ArgsAndReport = ([PosArg], PrintReport)
+
+-- | The result of parsing the arguments to a report. Failures are
+-- indicated with a Text. The name of the executable and the word
+-- @error@ will be prepended to this Text; otherwise, it is printed
+-- as-is, so be sure to include any trailing newline if needed.
+type ParseResult = Exceptional X.Text ArgsAndReport
+
+type PrintReport
+ = (L.Amount L.Qty -> X.Text)
+ -- ^ Function that gives a rendering for quantities that are not
+ -- already formatted. This function is passed as part of
+ -- PrintReport because it allows the function to be built after the
+ -- ledger has already been parsed.
+
+ -> [L.Transaction]
+ -- ^ All transactions to be included in the report. The report must
+ -- sort and filter them
+
+ -> [L.PricePoint]
+ -- ^ PricePoints to be included in the report
+
+
+ -> Exceptional X.Text [R.Chunk]
+ -- ^ The exception type is a strict Text, containing the error
+ -- message. The success type is a list of either a Chunk or a PreChunk
+ -- containing the resulting report. This allows for errors after the
+ -- list of transactions has been seen. The name of the executable and
+ -- the word @error@ will be prepended to this Text; otherwise, it is
+ -- printed as-is, so be sure to include any trailing newline if
+ -- needed.
+
+
+type Report = Runtime -> (HelpStr, MkReport)
+type MkReport
+ = CaseSensitive
+ -- ^ Result from previous parses indicating whether the user desires
+ -- case sensitivity (this may have been changed in the filtering
+ -- options)
+
+ -> (CaseSensitive -> X.Text -> Exceptional X.Text TM.Matcher)
+ -- ^ Result from previous parsers indicating the matcher factory the
+ -- user wishes to use
+
+ -> S.Changers
+ -- ^ Result from previous parsers indicating which color scheme to
+ -- use.
+
+ -> Exp.ExprDesc
+ -- ^ Result from previous parsers indicating whether the user wants
+ -- RPN or infix
+
+ -> ([L.Transaction] -> [(Ly.LibertyMeta, L.Posting)])
+ -- ^ Result from previous parsers that will sort and filter incoming
+ -- transactions
+
+ -> MA.Mode (MA.ProgName -> String) ParseResult
diff --git a/lib/Penny/Cabin/Meta.hs b/lib/Penny/Cabin/Meta.hs
new file mode 100644
index 0000000..4cbbe4f
--- /dev/null
+++ b/lib/Penny/Cabin/Meta.hs
@@ -0,0 +1,13 @@
+-- | Metadata that is specific to Cabin.
+module Penny.Cabin.Meta where
+
+import qualified Penny.Lincoln as L
+
+-- | Each row that is visible on screen is assigned a VisibleNum. This
+-- is used to number the rows in the report for the user's benefit. It
+-- is also used to determine whether the row is even or odd for the
+-- purpose of assigning the background color (this way the background
+-- colors can alternate, like a checkbook register.)
+newtype VisibleNum = VisibleNum { unVisibleNum :: L.Serial }
+ deriving (Eq, Show)
+
diff --git a/lib/Penny/Cabin/Options.hs b/lib/Penny/Cabin/Options.hs
new file mode 100644
index 0000000..7cf777f
--- /dev/null
+++ b/lib/Penny/Cabin/Options.hs
@@ -0,0 +1,16 @@
+-- | Options applicable to multiple Cabin reports.
+
+module Penny.Cabin.Options where
+
+-- | Whether to show zero balances in reports.
+newtype ShowZeroBalances =
+ ShowZeroBalances { unShowZeroBalances :: Bool }
+ deriving (Show, Eq)
+
+-- | Converts an ordering to a descending order.
+descending :: (a -> a -> Ordering)
+ -> a -> a -> Ordering
+descending f x y = case f x y of
+ LT -> GT
+ GT -> LT
+ EQ -> EQ
diff --git a/lib/Penny/Cabin/Parsers.hs b/lib/Penny/Cabin/Parsers.hs
new file mode 100644
index 0000000..a118e6a
--- /dev/null
+++ b/lib/Penny/Cabin/Parsers.hs
@@ -0,0 +1,24 @@
+-- | Command line parsers that are common to various Cabin reports.
+
+module Penny.Cabin.Parsers where
+
+import qualified Penny.Cabin.Options as CO
+import qualified System.Console.MultiArg.Combinator as C
+
+
+zeroBalances :: C.OptSpec CO.ShowZeroBalances
+zeroBalances = C.OptSpec ["zero-balances"] "" (C.ChoiceArg ls)
+ where
+ ls = [ ("show", CO.ShowZeroBalances True)
+ , ("hide", CO.ShowZeroBalances False) ]
+
+data SortOrder = Ascending | Descending deriving (Eq, Ord, Show)
+
+order :: C.OptSpec SortOrder
+order = C.OptSpec ["order"] "" (C.ChoiceArg ls)
+ where
+ ls = [ ("ascending", Ascending)
+ , ("descending", Descending) ]
+
+help :: C.OptSpec ()
+help = C.OptSpec ["help"] "h" (C.NoArg ())
diff --git a/lib/Penny/Cabin/Posts.hs b/lib/Penny/Cabin/Posts.hs
new file mode 100644
index 0000000..fc49bda
--- /dev/null
+++ b/lib/Penny/Cabin/Posts.hs
@@ -0,0 +1,585 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | The Penny Postings report
+--
+-- The Postings report displays postings in a tabular format designed
+-- to be read by humans. Some terminology used in the Postings report:
+--
+-- [@row@] The smallest unit that spans from left to right. A row,
+-- however, might consist of more than one screen line. For example,
+-- the running balance is shown on the far right side of the Postings
+-- report. The running balance might consist of more than one
+-- commodity. Each commodity is displayed on its own screen
+-- line. However, all these lines put together are displayed in a
+-- single row.
+--
+-- [@column@] The smallest unit that spans from top to bottom.
+--
+-- [@tranche@] Each posting is displayed in several rows. The group of
+-- rows that is displayed for a single posting is called a tranche.
+--
+-- [@tranche row@] Each tranche has a particular number of rows
+-- (currently four); each of these rows is known as a tranche row.
+--
+-- [@field@] Corresponds to a particular element of the posting, such
+-- as whether it is a debit or credit or its payee. The user can
+-- select which fields to see.
+--
+-- [@allocation@] The width of the Payee and Account fields is
+-- variable. Generally their width will adjust to fill the entire
+-- width of the screen. The allocations of the Payee and Account
+-- fields determine how much of the remaining space each field will
+-- receive.
+--
+-- The Postings report is easily customized from the command line to
+-- show various fields. However, the order of the fields is not
+-- configurable without editing the source code (sorry).
+
+module Penny.Cabin.Posts
+ ( postsReport
+ , zincReport
+ , defaultOptions
+ , ZincOpts(..)
+ , A.Alloc
+ , A.SubAccountLength(..)
+ , A.alloc
+ , yearMonthDay
+ , defaultWidth
+ , columnsVarToWidth
+ , widthFromRuntime
+ , defaultFields
+ , defaultSpacerWidth
+ , T.ReportWidth(..)
+ ) where
+
+import Control.Applicative ((<$>), (<*>))
+import qualified Control.Monad.Exception.Synchronous as Ex
+import Data.List.Split (chunksOf)
+import qualified Data.Either as Ei
+import qualified Data.Text as X
+import qualified Penny.Cabin.Interface as I
+import qualified Penny.Cabin.Options as CO
+import qualified Penny.Cabin.Posts.Allocated as A
+import qualified Penny.Cabin.Posts.Chunk as C
+import qualified Penny.Cabin.Posts.Fields as F
+import qualified Penny.Cabin.Posts.Meta as M
+import qualified Penny.Cabin.Posts.Parser as P
+import qualified Penny.Cabin.Posts.Spacers as S
+import qualified Penny.Cabin.Posts.Types as T
+import qualified Penny.Cabin.Scheme as E
+
+import qualified Penny.Lincoln as L
+import qualified Penny.Lincoln.Queries as Q
+import qualified Penny.Liberty as Ly
+import qualified Penny.Shield as Sh
+import qualified Data.Prednote.Expressions as Exp
+import qualified Data.Prednote.Pdct as Pe
+import qualified System.Console.Rainbow as Rb
+
+import Data.List (intersperse)
+import Data.Maybe (catMaybes)
+import qualified Data.Foldable as Fdbl
+import Data.Time as Time
+import qualified System.Console.MultiArg as MA
+import System.Locale (defaultTimeLocale)
+import Text.Matchers (CaseSensitive)
+
+-- | All information needed to make a Posts report. This function
+-- never fails.
+postsReport
+ :: E.Changers
+ -> CO.ShowZeroBalances
+ -> (Pe.Pdct (Ly.LibertyMeta, L.Posting))
+ -- ^ Removes posts from the report if applying this function to the
+ -- post returns False. Posts removed still affect the running
+ -- balance.
+
+ -> [Ly.PostFilterFn]
+ -- ^ Applies these post-filters to the list of posts that results
+ -- from applying the predicate above. Might remove more
+ -- postings. Postings removed still affect the running balance.
+
+ -> C.ChunkOpts
+ -> [(Ly.LibertyMeta, L.Posting)]
+ -> [Rb.Chunk]
+
+postsReport ch szb pdct pff co =
+ C.makeChunk ch co
+ . M.toBoxList szb pdct pff
+
+
+zincReport :: ZincOpts -> I.Report
+zincReport opts rt = (helpStr opts, md)
+ where
+ md cs fty ch expr fsf = MA.modeHelp
+ "postings"
+ (const (helpStr opts))
+ (process opts cs fty ch expr fsf)
+ (specs rt)
+ MA.Intersperse
+ (return . Left)
+
+specs
+ :: Sh.Runtime
+ -> [MA.OptSpec (Either String (P.State -> Ex.Exceptional X.Text P.State))]
+specs = map (fmap Right) . P.allSpecs
+
+
+process
+ :: ZincOpts
+ -> CaseSensitive
+ -> L.Factory
+ -> E.Changers
+ -> Exp.ExprDesc
+ -> ([L.Transaction] -> [(Ly.LibertyMeta, L.Posting)])
+ -> [Either String (P.State -> Ex.Exceptional X.Text P.State)]
+ -> Ex.Exceptional X.Text I.ArgsAndReport
+process os cs fty ch expr fsf ls =
+ let (posArgs, clOpts) = Ei.partitionEithers ls
+ pState = newParseState cs fty expr os
+ exState' = foldl (>>=) (return pState) clOpts
+ in fmap (mkPrintReport posArgs os ch fsf) exState'
+
+mkPrintReport
+ :: [String]
+ -> ZincOpts
+ -> E.Changers
+ -> ([L.Transaction] -> [(Ly.LibertyMeta, L.Posting)])
+ -> P.State
+ -> I.ArgsAndReport
+mkPrintReport posArgs zo ch fsf st = (posArgs, f)
+ where
+ f fmt txns _ = do
+ pdct <- getPredicate (P.exprDesc st) (P.tokens st)
+ let boxes = fsf txns
+ rptChks = postsReport ch (P.showZeroBalances st) pdct
+ (P.postFilter st) (chunkOpts fmt st zo) boxes
+ expChks = showExpression (P.showExpression st) pdct
+ verbChks = showVerboseFilter fmt (P.verboseFilter st)
+ pdct boxes
+ chks = expChks
+ ++ verbChks
+ ++ rptChks
+ return chks
+
+indentAmt :: Pe.IndentAmt
+indentAmt = 4
+
+blankLine :: Rb.Chunk
+blankLine = "\n"
+
+showExpression
+ :: P.ShowExpression
+ -> Pe.Pdct ((Ly.LibertyMeta, L.Posting))
+ -> [Rb.Chunk]
+showExpression (P.ShowExpression b) pdct =
+ if not b then [] else info : blankLine : (chks ++ [blankLine])
+ where
+ info = "Postings filter expression:\n"
+ chks = Pe.showPdct indentAmt 0 pdct
+
+showVerboseFilter
+ :: (L.Amount L.Qty -> X.Text)
+ -> P.VerboseFilter
+ -> Pe.Pdct (Ly.LibertyMeta, L.Posting)
+ -> [(Ly.LibertyMeta, L.Posting)]
+ -> [Rb.Chunk]
+showVerboseFilter fmt (P.VerboseFilter b) pdct bs =
+ if not b then [] else info : blankLine : (chks ++ [blankLine])
+ where
+ chks =
+ fst
+ $ Pe.verboseFilter ((L.display fmt) . snd) indentAmt False pdct bs
+ info = "Postings report filter:\n"
+
+defaultOptions
+ :: Sh.Runtime
+ -> ZincOpts
+defaultOptions rt = ZincOpts
+ { fields = defaultFields
+ , width = widthFromRuntime rt
+ , showZeroBalances = CO.ShowZeroBalances False
+ , dateFormat = yearMonthDay
+ , subAccountLength = A.SubAccountLength 2
+ , payeeAllocation = A.alloc 60
+ , accountAllocation = A.alloc 40
+ , spacers = defaultSpacerWidth
+ }
+
+
+type Error = X.Text
+
+getPredicate
+ :: Exp.ExprDesc
+ -> [Exp.Token ((Ly.LibertyMeta, L.Posting))]
+ -> Ex.Exceptional Error (Pe.Pdct ((Ly.LibertyMeta, L.Posting)))
+getPredicate d ts =
+ case ts of
+ [] -> return $ Pe.always
+ _ -> Exp.parseExpression d ts
+
+
+-- | All the information to configure the postings report if the
+-- options will be parsed in from the command line.
+data ZincOpts = ZincOpts
+ { fields :: F.Fields Bool
+ -- ^ Default fields to show in the report.
+
+ , width :: T.ReportWidth
+ -- ^ Gives the default report width. This can be
+ -- overridden on the command line. You can use the
+ -- information from the Runtime to make this as wide as
+ -- the current terminal.
+
+ , showZeroBalances :: CO.ShowZeroBalances
+ -- ^ Are commodities that have no balance shown in the Total fields
+ -- of the report?
+
+ , dateFormat :: (M.PostMeta, L.Posting) -> X.Text
+ -- ^ How to display dates. This function is applied to the
+ -- a PostingInfo so it has lots of information, but it
+ -- should return a date for use in the Date field.
+
+ , subAccountLength :: A.SubAccountLength
+ -- ^ When shortening the names of sub accounts to make
+ -- them fit, they will be this long.
+
+ , payeeAllocation :: A.Alloc
+ -- ^ This and accountAllocation determine how much space
+ -- payees and accounts receive. They divide up the
+ -- remaining space after everything else is displayed. For
+ -- instance if payeeAllocation is 60 and accountAllocation
+ -- is 40, the payee takes about 60 percent of the
+ -- remaining space and the account takes about 40 percent.
+
+ , accountAllocation :: A.Alloc
+ -- ^ See payeeAllocation above
+
+ , spacers :: S.Spacers Int
+ -- ^ Default width for spacer fields. If any of these Ints are
+ -- less than or equal to zero, there will be no spacer. There is
+ -- never a spacer for fields that do not appear in the report.
+
+ }
+
+chunkOpts
+ :: (L.Amount L.Qty -> X.Text)
+ -> P.State
+ -> ZincOpts
+ -> C.ChunkOpts
+chunkOpts fmt s z = C.ChunkOpts
+ { C.dateFormat = dateFormat z
+ , C.qtyFormat = fmt
+ , C.fields = P.fields s
+ , C.subAccountLength = subAccountLength z
+ , C.payeeAllocation = payeeAllocation z
+ , C.accountAllocation = accountAllocation z
+ , C.spacers = spacers z
+ , C.reportWidth = P.width s
+ }
+
+
+newParseState ::
+ CaseSensitive
+ -> L.Factory
+ -> Exp.ExprDesc
+ -> ZincOpts
+ -> P.State
+newParseState cs fty expr o = P.State
+ { P.sensitive = cs
+ , P.factory = fty
+ , P.tokens = []
+ , P.postFilter = []
+ , P.fields = fields o
+ , P.width = width o
+ , P.showZeroBalances = showZeroBalances o
+ , P.exprDesc = expr
+ , P.verboseFilter = P.VerboseFilter False
+ , P.showExpression = P.ShowExpression False
+ }
+
+-- | Shows the date of a posting in YYYY-MM-DD format.
+yearMonthDay :: (M.PostMeta, L.Posting) -> X.Text
+yearMonthDay p = X.pack (Time.formatTime defaultTimeLocale fmt d)
+ where
+ d = L.day
+ . Q.dateTime
+ . snd
+ $ p
+ fmt = "%Y-%m-%d"
+
+-- | The default width for the report.
+defaultWidth :: T.ReportWidth
+defaultWidth = T.ReportWidth 80
+
+-- | Applied to the value of the COLUMNS environment variable, returns
+-- an appropriate ReportWidth.
+columnsVarToWidth :: Maybe String -> T.ReportWidth
+columnsVarToWidth ms = case ms of
+ Nothing -> defaultWidth
+ Just str -> case reads str of
+ [] -> defaultWidth
+ (i, []):[] -> if i > 0 then T.ReportWidth i else defaultWidth
+ _ -> defaultWidth
+
+-- | Given the Runtime, use the defaultWidth given above to calculate
+-- the report's width if COLUMNS does not yield a value. Otherwise,
+-- use what is in COLUMNS.
+widthFromRuntime :: Sh.Runtime -> T.ReportWidth
+widthFromRuntime rt = case Sh.screenWidth rt of
+ Nothing -> defaultWidth
+ Just w -> T.ReportWidth . Sh.unScreenWidth $ w
+
+-- | Default fields to show in the Postings report.
+defaultFields :: F.Fields Bool
+defaultFields =
+ F.Fields { F.globalTransaction = False
+ , F.revGlobalTransaction = False
+ , F.globalPosting = False
+ , F.revGlobalPosting = False
+ , F.fileTransaction = False
+ , F.revFileTransaction = False
+ , F.filePosting = False
+ , F.revFilePosting = False
+ , F.filtered = False
+ , F.revFiltered = False
+ , F.sorted = False
+ , F.revSorted = False
+ , F.visible = False
+ , F.revVisible = False
+ , F.lineNum = False
+ , F.date = True
+ , F.flag = False
+ , F.number = False
+ , F.payee = True
+ , F.account = True
+ , F.postingDrCr = True
+ , F.postingCmdty = True
+ , F.postingQty = True
+ , F.totalDrCr = True
+ , F.totalCmdty = True
+ , F.totalQty = True
+ , F.tags = False
+ , F.memo = False
+ , F.filename = False }
+
+-- | Default width of spacers; most are one character wide, but the
+-- spacer after payee is 4 characters wide.
+defaultSpacerWidth :: S.Spacers Int
+defaultSpacerWidth =
+ S.Spacers { S.globalTransaction = 1
+ , S.revGlobalTransaction = 1
+ , S.globalPosting = 1
+ , S.revGlobalPosting = 1
+ , S.fileTransaction = 1
+ , S.revFileTransaction = 1
+ , S.filePosting = 1
+ , S.revFilePosting = 1
+ , S.filtered = 1
+ , S.revFiltered = 1
+ , S.sorted = 1
+ , S.revSorted = 1
+ , S.visible = 1
+ , S.revVisible = 1
+ , S.lineNum = 1
+ , S.date = 1
+ , S.flag = 1
+ , S.number = 1
+ , S.payee = 4
+ , S.account = 1
+ , S.postingDrCr = 1
+ , S.postingCmdty = 1
+ , S.postingQty = 1
+ , S.totalDrCr = 1
+ , S.totalCmdty = 1 }
+
+------------------------------------------------------------
+-- ## Help
+------------------------------------------------------------
+
+ifDefault :: Bool -> String
+ifDefault b = if b then " (default)" else ""
+
+helpStr :: ZincOpts -> String
+helpStr o = unlines $
+ [ "postings"
+ , " Show postings in order with a running balance."
+ , " Accepts the following options:"
+ , ""
+ , "Posting filters"
+ , "==============="
+ , "These options affect which postings are shown in the report."
+ , "Postings not shown still affect the running balance."
+ , ""
+ , "Dates"
+ , "-----"
+ , ""
+ , "--date cmp timespec, -d cmp timespec"
+ , " Date must be within the time frame given. timespec"
+ , " is a day or a day and a time. Valid values for cmp:"
+ , " <, >, <=, >=, ==, /=, !="
+ , "--current"
+ , " Same as \"--date <= (right now) \""
+ , ""
+ , "Serials"
+ , "-------"
+ , "These options take the form --option cmp num; the given"
+ , "sequence number must fall within the given range. \"rev\""
+ , "in the option name indicates numbering is from end to beginning."
+ , ""
+ , "--globalTransaction, --revGlobalTransaction"
+ , " All transactions, after reading the ledger files"
+ , "--globalPosting, --revGlobalPosting"
+ , " All postings, after reading the leder files"
+ , "--fileTransaction, --revFileTransaction"
+ , " Transactions in each ledger file, after reading the files"
+ , " (numbering restarts with each file)"
+ , "--filePosting, --revFilePosting"
+ , " Postings in each ledger file, after reading the files"
+ , " (numbering restarts with each file)"
+ , "--filtered, --revFiltered"
+ , " All postings, after filters given in the filter"
+ , " specification portion of the command line are"
+ , " applied"
+ , "--sorted, --revSorted"
+ , " All postings remaining after filtering and after"
+ , " postings have been sorted"
+ , ""
+ , "Pattern matching"
+ , "----------------"
+ , ""
+ , "-a pattern, --account pattern"
+ , " Pattern must match colon-separated account name"
+ , "--account-level num pat"
+ , " Pattern must match sub account at given level"
+ , "--account-any pat"
+ , " Pattern must match sub account at any level"
+ , "-p pattern, --payee pattern"
+ , " Payee must match pattern"
+ , "-t pattern, --tag pattern"
+ , " Tag must match pattern"
+ , "--number pattern"
+ , " Number must match pattern"
+ , "--flag pattern"
+ , " Flag must match pattern"
+ , "--commodity pattern"
+ , " Pattern must match colon-separated commodity name"
+ , "--posting-memo pattern"
+ , " Posting memo must match pattern"
+ , "--transaction-memo pattern"
+ , " Transaction memo must match pattern"
+ , ""
+ , "Other posting characteristics"
+ , "-----------------------------"
+ , "--debit"
+ , " Entry must be a debit"
+ , "--credit"
+ , " Entry must be a credit"
+ , "--qty cmp number"
+ , " Entry quantity must fall within given range"
+ , ""
+ , "Infix or RPN selection"
+ , "----------------------"
+ , "--infix - use infix notation"
+ , "--rpn - use reverse polish notation"
+ , " (default: use what was used in the filtering options)"
+ , ""
+ , "Infix Operators - from highest to lowest precedence"
+ , "(all are left associative)"
+ , "--------------------------"
+ , "--open expr --close"
+ , " Force precedence (as in \"open\" and \"close\" parentheses)"
+ , "--not expr"
+ , " True if expr is false"
+ , "expr1 --and expr2 "
+ , " True if expr and expr2 are both true"
+ , "expr1 --or expr2"
+ , " True if either expr1 or expr2 is true"
+ , ""
+ , "RPN Operators"
+ , "-------------"
+ , "expr --not"
+ , " True if expr is false"
+ , "expr1 expr2 --and"
+ , " True if expr and expr2 are both true"
+ , "expr1 expr2 --or"
+ , " True if either expr1 or expr2 is true"
+ , ""
+ , "Options affecting patterns"
+ , "=========================="
+ , ""
+ , "-i, --case-insensitive"
+ , " Be case insensitive"
+ , "-I, --case-sensitive"
+ , " Be case sensitive"
+ , ""
+ , "--within"
+ , " Use \"within\" matcher"
+ , "--pcre"
+ , " Use \"pcre\" matcher"
+ , "--posix"
+ , " Use \"posix\" matcher"
+ , "--exact"
+ , " Use \"exact\" matcher"
+ , ""
+ , "Removing postings after sorting and filtering"
+ , "============================================="
+ , "--head n"
+ , " Keep only the first n postings"
+ , "--tail n"
+ , " Keep only the last n postings"
+ , ""
+ , "Other options"
+ , "============="
+ , "--width num"
+ , " Hint for roughly how wide the report should be in columns"
+ , " (currently: " ++ (show . T.unReportWidth . width $ o) ++ ")"
+ , "--show field, --hide field"
+ , " show or hide this field, where field is one of:"
+ , " globalTransaction, revGlobalTransaction,"
+ , " globalPosting, revGlobalPosting,"
+ , " fileTransaction, revFileTransaction,"
+ , " filePosting, revFilePosting,"
+ , " filtered, revFiltered,"
+ , " sorted, revSorted,"
+ , " visible, revVisible,"
+ , " lineNum,"
+ , " date, flag, number, payee, account,"
+ , " postingDrCr, postingCommodity, postingQty,"
+ , " totalDrCr, totalCommodity, totalQty,"
+ , " tags, memo, filename"
+ , "--show-all"
+ , " Show all fields"
+ , "--hide-all"
+ , " Hide all fields"
+ , ""
+ ] ++ showDefaultFields (fields o) ++
+ [ ""
+ , "--show-zero-balances"
+ , " Show balances that are zero"
+ ++ ifDefault (CO.unShowZeroBalances . showZeroBalances $ o)
+ , "--hide-zero-balances"
+ , " Hide balances that are zero"
+ ++ ifDefault (not . CO.unShowZeroBalances . showZeroBalances $ o)
+ , ""
+ , "--help, -h"
+ , " Show this help and exit"
+ ]
+
+-- | Shows which fields are on by default.
+showDefaultFields :: F.Fields Bool -> [String]
+showDefaultFields i = hdr : rest
+ where
+ hdr = "Fields shown by default:"
+ ++ if null rest then " (none)" else ""
+ rest =
+ map (" " ++)
+ . map concat
+ . map (intersperse ", ")
+ . chunksOf 3
+ . catMaybes
+ . Fdbl.toList
+ . toMaybes
+ $ i
+ toMaybes flds = f <$> flds <*> F.fieldNames
+ f b n = if b then Just n else Nothing
diff --git a/lib/Penny/Cabin/Posts/Allocated.hs b/lib/Penny/Cabin/Posts/Allocated.hs
new file mode 100644
index 0000000..b3b2e53
--- /dev/null
+++ b/lib/Penny/Cabin/Posts/Allocated.hs
@@ -0,0 +1,402 @@
+-- | Calculates the allocated cells -- the Payee cell and the Account
+-- cell. Here is the logic for this process:
+--
+-- 1. If neither Payee nor Account appears, do nothing.
+--
+-- 2. Obtain the width of the growing cells, including the
+-- spacers. One of the spacers attached to a field might be omitted:
+--
+-- a. If the rightmost growing field is TotalQty, include all spacers.
+--
+-- b. If the rightmost growing field is to the left of Payee, include
+-- all spacers.
+--
+-- c. If the rightmost growing field is to the right of Account but is
+-- not TotalQty, omit its spacer.
+--
+-- 2. Obtain the width of the Payee and Account spacers. Include each
+-- spacer if its corresponding field appears in the report.
+--
+-- 3. Subtract from the total report width the width of the the
+-- growing cells and the width of the Payee and Account spacers. This
+-- gives the total width available for the Payee and Account
+-- fields. If there are not at least two columns available, return
+-- without including the Payee and Account fields.
+--
+-- 4. Determine the total width that the Payee and Account fields
+-- would obtain if they had all the space they could ever need. This
+-- is the "requested width".
+--
+-- 5. Split up the available width for the Payee and Account fields
+-- depending on which fields appear:
+--
+-- a. If only the one field appears, then it shall be as wide as the
+-- total available width or the its requested width, whichever is
+-- smaller.
+--
+-- b. If both fields appear, then calculate the allocated width for
+-- each field. If either field's requested width is less than its
+-- allocated width, then that field is only as wide as its requested
+-- width. The other field is then as wide as (the sum of its allocated
+-- width and the leftover width from the other field) or its requested
+-- width, whichever is smaller. If neither field's requested width is
+-- less than its allocated width, then each field gets ts allocated
+-- width.
+--
+-- 6. Fill cell contents; return filled cells.
+
+module Penny.Cabin.Posts.Allocated (
+ payeeAndAcct
+ , AllocatedOpts(..)
+ , Fields(..)
+ , SubAccountLength(..)
+ , Alloc
+ , alloc
+ , unAlloc
+ ) where
+
+import Control.Applicative(Applicative((<*>), pure), (<$>))
+import Control.Arrow (second)
+import Data.Maybe (catMaybes, isJust)
+import Data.Monoid (mempty)
+import Data.List (intersperse)
+import qualified Data.Foldable as Fdbl
+import qualified Data.Sequence as Seq
+import qualified Data.Traversable as T
+import qualified Data.Text as X
+import qualified System.Console.Rainbow as Rb
+import qualified Penny.Cabin.Row as R
+import qualified Penny.Cabin.Posts.Growers as G
+import qualified Penny.Cabin.Posts.Meta as M
+import qualified Penny.Cabin.Posts.Spacers as S
+import qualified Penny.Cabin.Posts.Types as Ty
+import qualified Penny.Cabin.Scheme as E
+import qualified Penny.Cabin.TextFormat as TF
+import qualified Penny.Lincoln as L
+import qualified Penny.Lincoln.Bits.Qty as Qty
+import qualified Penny.Lincoln.Queries as Q
+import qualified Penny.Lincoln.HasText as HT
+
+data Fields a = Fields {
+ payee :: a
+ , account :: a
+ } deriving (Eq, Show)
+
+newtype SubAccountLength =
+ SubAccountLength { unSubAccountLength :: Int }
+ deriving Show
+
+newtype Alloc = Alloc { unAlloc :: Int }
+ deriving Show
+
+alloc :: Int -> Alloc
+alloc i =
+ if i < 1
+ then error $ "allocations must be greater than zero."
+ ++ " supplied allocation: " ++ show i
+ else Alloc i
+
+
+-- | All the information needed for allocated cells.
+data AllocatedOpts = AllocatedOpts
+ { fields :: Fields Bool
+ , subAccountLength :: SubAccountLength
+ , allocations :: Fields Alloc
+ , spacers :: S.Spacers Int
+ , growerWidths :: G.Fields (Maybe Int)
+ , reportWidth :: Ty.ReportWidth
+ }
+
+-- | Creates Payee and Account cells. The user must have requested the
+-- cells. In addition, no cells are created if there is not enough
+-- space for them in the report. Returns a Fields; each element of the
+-- Fields is Nothing if no cells were created (either because the user
+-- did not ask for them, or because there was no room) or Just cs i,
+-- where cs is a list of all the cells, and i is the width of all the
+-- cells.
+payeeAndAcct
+ :: E.Changers
+ -> AllocatedOpts
+ -> [(M.PostMeta, L.Posting)]
+ -> Fields (Maybe ([R.ColumnSpec], Int))
+payeeAndAcct ch ao bs =
+ let allBuilders =
+ T.traverse (builders ch (subAccountLength ao)) bs
+ availWidth = availableWidthForAllocs (growerWidths ao)
+ (spacers ao) (fields ao) (reportWidth ao)
+ finals = divideAvailableWidth availWidth (fields ao)
+ (allocations ao)
+ ( fmap (safeMaximum (Request 0))
+ . fmap (fmap fst) $ allBuilders)
+ in fmap (fmap (second unFinal))
+ . buildSpecs finals
+ . fmap (fmap snd)
+ $ allBuilders
+
+
+safeMaximum :: Ord a => a -> [a] -> a
+safeMaximum d ls = case ls of
+ [] -> d
+ xs -> maximum xs
+
+payeeAndAccountSpacerWidth
+ :: Fields Bool
+ -> S.Spacers Int
+ -> Int
+payeeAndAccountSpacerWidth flds ss = pye + act
+ where
+ pye = if payee flds then abs (S.payee ss) else 0
+ act = if account flds then abs (S.account ss) else 0
+
+newtype AvailableWidth = AvailableWidth Int
+ deriving (Eq, Ord, Show)
+
+availableWidthForAllocs
+ :: G.Fields (Maybe Int)
+ -> S.Spacers Int
+ -> Fields Bool
+ -> Ty.ReportWidth
+ -> AvailableWidth
+availableWidthForAllocs growers ss flds (Ty.ReportWidth w) =
+ AvailableWidth $ max 0 diff
+ where
+ tot = sumGrowersAndSpacers growers ss
+ + payeeAndAccountSpacerWidth flds ss
+ diff = w - tot
+
+-- | Sums spacers for growing cells. This function is intended for use
+-- only by the functions that allocate cells for the report, so it
+-- assumes that either the Payee or the Account field is showing. Sums
+-- all spacers, UNLESS the rightmost field is from PostingDrCr to
+-- TotalCmdty, in which case the rightmost spacer is omitted. Apply to
+-- the second element of the tuple returned by growCells (which
+-- reflects which fields actually have width) and to the accompanying
+-- Spacers.
+sumSpacers ::
+ G.Fields (Maybe a)
+ -> S.Spacers Int
+ -> Int
+sumSpacers fs =
+ sum
+ . map fst
+ . appearingSpacers
+ . catMaybes
+ . Fdbl.toList
+ . fmap toWidth
+ . pairedWithSpacers fs
+
+
+-- | Takes a triple:
+--
+-- * The first element is Just _ if the field appears in the report;
+-- Nothing if not
+--
+-- * The second element is Maybe Int for the width of the spacer
+-- (TotalQty has no spacer, so it will be Nothing)
+--
+-- * The third element is the EFields tag
+--
+-- Returns Nothing if the field does not appear in the report. Returns
+-- Just a pair if the field does appear in the report, where the first
+-- element is the width of the spacer, and the second element is the
+-- EFields tag.
+toWidth :: (Maybe a, Maybe Int, t) -> Maybe (Int, t)
+toWidth (maybeShowing, maybeWidth, tag) =
+ if isJust maybeShowing
+ then case maybeWidth of
+ Just w -> Just (w, tag)
+ Nothing -> Just (0, tag)
+ else Nothing
+
+
+-- | Given a list of all spacers that are attached to the fields that
+-- are present in a report, return a list of the spacers that will
+-- actually appear in the report. The rightmost spacer does not appear
+-- if it is to the right of Account (unless there is a TotalQty field,
+-- in which case, all spacers appear because TotalQty has no spacer.)
+appearingSpacers :: [(Int, G.EFields)] -> [(Int, G.EFields)]
+appearingSpacers ss = case ss of
+ [] -> []
+ l -> case snd $ last l of
+ G.ETotalQty -> l
+ t -> if t > G.ENumber
+ then init l
+ else l
+
+-- | Applied to two arguments: first, a Fields, and second, a
+-- Spacers. Combines each Field with its corresponding Spacer and with
+-- the GFields, which indicates each particular field.
+pairedWithSpacers ::
+ G.Fields a
+ -> S.Spacers b
+ -> G.Fields (a, Maybe b, G.EFields)
+pairedWithSpacers f s =
+ (\(a, b) c -> (a, b, c))
+ <$> G.pairWithSpacer f s
+ <*> G.eFields
+
+-- | Sums the widths of growing cells and their accompanying
+-- spacers; makes the adjustments described in sumSpacers.
+sumGrowersAndSpacers ::
+ G.Fields (Maybe Int)
+ -> S.Spacers Int
+ -> Int
+sumGrowersAndSpacers fs ss = spcrs + flds where
+ spcrs = sumSpacers fs ss
+ flds = Fdbl.foldr f 0 fs where
+ f maybeI acc = case maybeI of
+ Nothing -> acc
+ Just i -> acc + i
+
+newtype Request = Request { unRequest :: Int }
+ deriving (Eq, Ord, Show)
+
+newtype Final = Final { unFinal :: Int }
+ deriving (Eq, Ord, Show)
+
+
+buildSpecs
+ :: Fields (Maybe Final)
+ -> Fields ([Final -> R.ColumnSpec])
+ -> Fields (Maybe ([R.ColumnSpec], Final))
+buildSpecs finals bs = f <$> finals <*> bs
+ where
+ f mayFinal gs = case mayFinal of
+ Nothing -> Nothing
+ Just fin -> Just ((gs <*> pure fin), fin)
+
+
+-- | Divide the total available width between the two fields.
+divideAvailableWidth
+ :: AvailableWidth
+ -> Fields Bool
+ -> Fields Alloc
+ -> Fields Request
+ -> Fields (Maybe Final)
+divideAvailableWidth (AvailableWidth aw) appear allocs rws = Fields pye act
+ where
+ minFinal i1 i2 =
+ let m = min i1 i2
+ in if m > 0 then Just . Final $ m else Nothing
+ pairAtLeast i1 i2 = (atLeast i1, atLeast i2)
+ where atLeast i = if i > 0 then Just . Final $ i else Nothing
+ reqP = unRequest . payee $ rws
+ reqA = unRequest . account $ rws
+ (pye, act) = case (payee appear, account appear) of
+ (False, False) -> (Nothing, Nothing)
+ (True, False) -> (minFinal reqP aw, Nothing)
+ (False, True) -> (Nothing, minFinal reqA aw)
+ (True, True) ->
+ let votes = [unAlloc . payee $ allocs, unAlloc . account $ allocs]
+ allocRslt = Qty.largestRemainderMethod (fromIntegral aw)
+ (map fromIntegral votes)
+ (allocP, allocA) = case allocRslt of
+ x:y:[] -> (fromIntegral x, fromIntegral y)
+ _ -> error "divideAvailableWidth error"
+ in case (allocP > reqP, allocA > reqA) of
+ (True, True) -> pairAtLeast reqP reqA
+ (True, False) ->
+ pairAtLeast reqP $ (min (allocA + (allocP - reqP))) reqA
+ (False, True) ->
+ pairAtLeast (min reqP (allocP + (allocA - reqA))) reqA
+ (False, False) -> pairAtLeast allocP allocA
+
+
+builders
+ :: E.Changers
+ -> SubAccountLength
+ -> (M.PostMeta, L.Posting)
+ -> Fields (Request, Final -> R.ColumnSpec)
+builders ch sl b = Fields (buildPayee ch b) (buildAcct ch sl b)
+
+buildPayee
+ :: E.Changers
+ -> (M.PostMeta, L.Posting)
+ -> (Request, Final -> R.ColumnSpec)
+ -- ^ Returns a tuple. The first element is the maximum width that
+ -- this cell needs to display its value perfectly. The second
+ -- element is a function that, when applied to an actual width,
+ -- returns a ColumnSpec.
+
+buildPayee ch i = (maxW, mkSpec)
+ where
+ pb = snd i
+ eo = E.fromVisibleNum . M.visibleNum . fst $ i
+ j = R.LeftJustify
+ ps = (E.Other, eo)
+ md = E.getEvenOddLabelValue E.Other eo ch
+ mayPye = Q.payee pb
+ maxW = Request $ maybe 0 (X.length . HT.text) mayPye
+ mkSpec (Final w) = R.ColumnSpec j (R.Width w) ps sq
+ where
+ sq = case mayPye of
+ Nothing -> []
+ Just pye ->
+ let wrapped =
+ Fdbl.toList
+ . TF.unLines
+ . TF.wordWrap w
+ . TF.txtWords
+ . HT.text
+ $ pye
+ toBit (TF.Words seqTxts) =
+ md
+ . Rb.Chunk mempty
+ . X.unwords
+ . Fdbl.toList
+ $ seqTxts
+ in fmap toBit wrapped
+
+
+buildAcct
+ :: E.Changers
+ -> SubAccountLength
+ -> (M.PostMeta, L.Posting)
+ -> (Request, Final -> R.ColumnSpec)
+ -- ^ Returns a tuple. The first element is the maximum width that
+ -- this cell needs to display its value perfectly. The second
+ -- element is a function that, when applied to an actual width,
+ -- returns a ColumnSpec.
+
+buildAcct ch sl i = (maxW, mkSpec)
+ where
+ pb = snd i
+ eo = E.fromVisibleNum . M.visibleNum . fst $ i
+ ps = (E.Other, eo)
+ aList = L.unAccount . Q.account $ pb
+ maxW = Request
+ $ (sum . map (X.length . L.unSubAccount) $ aList)
+ + max 0 (length aList - 1)
+ md = E.getEvenOddLabelValue E.Other eo ch
+ mkSpec (Final aw) = R.ColumnSpec R.LeftJustify (R.Width aw) ps sq
+ where
+ target = TF.Target aw
+ shortest = TF.Shortest . unSubAccountLength $ sl
+ ws = TF.Words . Seq.fromList . map L.unSubAccount $ aList
+ (TF.Words shortened) = TF.shorten shortest target ws
+ sq = [ md
+ . Rb.Chunk mempty
+ . X.concat
+ . intersperse (X.singleton ':')
+ . Fdbl.toList
+ $ shortened ]
+
+instance Functor Fields where
+ fmap f i = Fields {
+ payee = f (payee i)
+ , account = f (account i) }
+
+instance Applicative Fields where
+ pure a = Fields a a
+ ff <*> fa = Fields {
+ payee = payee ff (payee fa)
+ , account = account ff (account fa) }
+
+instance Fdbl.Foldable Fields where
+ foldr f z flds =
+ f (payee flds) (f (account flds) z)
+
+instance T.Traversable Fields where
+ traverse f flds =
+ Fields <$> f (payee flds) <*> f (account flds)
+
diff --git a/lib/Penny/Cabin/Posts/BottomRows.hs b/lib/Penny/Cabin/Posts/BottomRows.hs
new file mode 100644
index 0000000..c12ef6e
--- /dev/null
+++ b/lib/Penny/Cabin/Posts/BottomRows.hs
@@ -0,0 +1,649 @@
+-- | Fills the bottom rows, which contain the tags, memo, and
+-- filename. These rows are formatted as follows:
+--
+-- * If the columns for TotalDrCr, TotalCmdty, and TotalQty are all
+-- present, AND if there are at least TWO other columns present, then
+-- there will be a hanging indent. The bottom rows will begin at the
+-- SECOND column and end with the last column to the left of
+-- TotalDrCr. In this case, each bottom row will have three cells: one
+-- padding on the left, one main content, and one padding on the
+-- right.
+--
+-- * Otherwise, if there are NO columns in the top row, these rows
+-- will take the entire width of the report. Each bottom row will have
+-- one cell.
+--
+-- * Otherwise, the bottom rows are as wide as all the top cells
+-- combined. Each bottom row will have one cell.
+
+module Penny.Cabin.Posts.BottomRows (
+ BottomOpts(..),
+ bottomRows, Fields(..), TopRowCells(..), mergeWithSpacers,
+ topRowCells) where
+
+import Control.Applicative((<$>), Applicative(pure, (<*>)))
+import qualified Data.Foldable as Fdbl
+import Control.Monad (guard)
+import Data.List (intersperse, find)
+import qualified Data.List.NonEmpty as NE
+import Data.Maybe (catMaybes)
+import Data.Monoid (mappend, mempty, First(First, getFirst))
+import qualified Data.Sequence as Seq
+import qualified Data.Text as X
+import qualified Data.Traversable as T
+import qualified System.Console.Rainbow as Rb
+import qualified Penny.Cabin.Scheme as E
+import qualified Penny.Cabin.Row as R
+import qualified Penny.Cabin.TextFormat as TF
+import qualified Penny.Cabin.Posts.Allocated as A
+import qualified Penny.Cabin.Posts.Fields as F
+import qualified Penny.Cabin.Posts.Growers as G
+import qualified Penny.Cabin.Posts.Meta as M
+import qualified Penny.Cabin.Posts.Spacers as S
+import qualified Penny.Cabin.Posts.Types as Ty
+import qualified Penny.Lincoln as L
+import qualified Penny.Lincoln.HasText as HT
+import qualified Penny.Lincoln.Queries as Q
+
+data BottomOpts = BottomOpts
+ { growingWidths :: G.Fields (Maybe Int)
+ , allocatedWidths :: A.Fields (Maybe Int)
+ , fields :: F.Fields Bool
+ , reportWidth :: Ty.ReportWidth
+ , spacers :: S.Spacers Int
+ }
+
+bottomRows
+ :: E.Changers
+ -> BottomOpts
+ -> [(M.PostMeta, L.Posting)]
+ -> Fields (Maybe [[Rb.Chunk]])
+bottomRows ch os bs = makeRows bs pcs where
+ pcs = infoProcessors ch topSpecs (reportWidth os) wanted
+ wanted = requestedMakers ch (fields os)
+ topSpecs = topCellSpecs (growingWidths os) (allocatedWidths os)
+ (spacers os)
+
+
+data Fields a = Fields {
+ tags :: a
+ , memo :: a
+ , filename :: a
+ } deriving (Show, Eq)
+
+instance Fdbl.Foldable Fields where
+ foldr f z d =
+ f (tags d)
+ (f (memo d)
+ (f (filename d) z))
+
+instance Functor Fields where
+ fmap f (Fields t m fn) =
+ Fields (f t) (f m) (f fn)
+
+instance Applicative Fields where
+ pure a = Fields a a a
+ ff <*> fa = Fields {
+ tags = (tags ff) (tags fa)
+ , memo = (memo ff) (memo fa)
+ , filename = (filename ff) (filename fa)
+ }
+
+bottomRowsFields :: F.Fields a -> Fields a
+bottomRowsFields f = Fields {
+ tags = F.tags f
+ , memo = F.memo f
+ , filename = F.filename f }
+
+
+data Hanging a = Hanging {
+ leftPad :: a
+ , mainCell :: a
+ , rightPad :: a
+ } deriving (Show, Eq)
+
+
+newtype SpacerWidth = SpacerWidth Int deriving (Show, Eq)
+newtype ContentWidth = ContentWidth Int deriving (Show, Eq)
+
+
+hanging
+ :: E.Changers
+ -> [TopCellSpec]
+ -> Maybe (((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))
+ -> (M.PostMeta, L.Posting) -> [Rb.Chunk])
+hanging ch specs = hangingWidths specs
+ >>= return . hangingInfoProcessor ch
+
+hangingInfoProcessor
+ :: E.Changers
+ -> Hanging Int
+ -> ((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))
+ -> (M.PostMeta, L.Posting)
+ -> [Rb.Chunk]
+hangingInfoProcessor ch widths mkr info = row where
+ row = R.row ch [left, mid, right]
+ (ts, mid) = mkr info (mainCell widths)
+ mkPad w = R.ColumnSpec R.LeftJustify (R.Width w) ts []
+ left = mkPad (leftPad widths)
+ right = mkPad (rightPad widths)
+
+widthOfTopColumns
+ :: E.Changers
+ -> [TopCellSpec]
+ -> Maybe (((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))
+ -> (M.PostMeta, L.Posting) -> [Rb.Chunk])
+widthOfTopColumns ch ts =
+ if null ts
+ then Nothing
+ else Just $ makeSpecificWidth ch w where
+ w = Fdbl.foldl' f 0 ts
+ f acc (_, maySpcWidth, (ContentWidth cw)) =
+ acc + cw + maybe 0 (\(SpacerWidth sw) -> sw) maySpcWidth
+
+
+widthOfReport
+ :: E.Changers
+ -> Ty.ReportWidth
+ -> ((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))
+ -> (M.PostMeta, L.Posting)
+ -> [Rb.Chunk]
+widthOfReport ch (Ty.ReportWidth rw) fn info =
+ makeSpecificWidth ch rw fn info
+
+chooseProcessor
+ :: E.Changers
+ -> [TopCellSpec]
+ -> Ty.ReportWidth
+ -> ((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))
+ -> (M.PostMeta, L.Posting)
+ -> [Rb.Chunk]
+chooseProcessor ch specs rw fn = let
+ firstTwo = First (hanging ch specs)
+ `mappend` First (widthOfTopColumns ch specs)
+ in case getFirst firstTwo of
+ Nothing -> widthOfReport ch rw fn
+ Just r -> r fn
+
+infoProcessors
+ :: E.Changers
+ -> [TopCellSpec]
+ -> Ty.ReportWidth
+ -> Fields (Maybe ((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)))
+ -> Fields (Maybe ((M.PostMeta, L.Posting) -> [Rb.Chunk]))
+infoProcessors ch specs rw flds = let
+ chooser = chooseProcessor ch specs rw
+ mkProcessor mayFn = case mayFn of
+ Nothing -> Nothing
+ Just fn -> Just $ chooser fn
+ in mkProcessor <$> flds
+
+
+makeRows ::
+ [(M.PostMeta, L.Posting)]
+ -> Fields (Maybe ((M.PostMeta, L.Posting) -> [Rb.Chunk]))
+ -> Fields (Maybe [[Rb.Chunk]])
+makeRows is flds = let
+ mkRow fn = map fn is
+ in fmap (fmap mkRow) flds
+
+
+-- | Calculates column widths for a Hanging report. If it cannot
+-- calculate the widths (because these cells do not support hanging),
+-- returns Nothing.
+hangingWidths :: [TopCellSpec]
+ -> Maybe (Hanging Int)
+hangingWidths ls = do
+ let len = length ls
+ guard (len > 4)
+ let matchColumn x (c, _, _) = x == c
+ totDrCr <- find (matchColumn ETotalDrCr) ls
+ totCmdty <- find (matchColumn ETotalCmdty) ls
+ totQty <- find (matchColumn ETotalQty) ls
+ let (first:middle) = take (len - 3) ls
+ mid <- NE.nonEmpty middle
+ return $ calcHangingWidths first mid (totDrCr, totCmdty, totQty)
+
+type TopCellSpec = (ETopRowCells, Maybe SpacerWidth, ContentWidth)
+
+-- | Given the first column in the top row, at least one middle
+-- column, and the last three columns, calculate the width of the
+-- three columns in the hanging report.
+calcHangingWidths ::
+ TopCellSpec
+ -> NE.NonEmpty TopCellSpec
+ -> (TopCellSpec, TopCellSpec, TopCellSpec)
+ -> Hanging Int
+calcHangingWidths l m r = Hanging left middle right where
+ calcWidth (_, maybeSp, (ContentWidth c)) =
+ c + maybe 0 (\(SpacerWidth w) -> abs w) maybeSp
+ left = calcWidth l
+ middle = Fdbl.foldl' f 0 m where
+ f acc c = acc + calcWidth c
+ (totDrCr, totCmdty, totQty) = r
+ right = calcWidth totDrCr + calcWidth totCmdty
+ + calcWidth totQty
+
+
+topCellSpecs :: G.Fields (Maybe Int)
+ -> A.Fields (Maybe Int)
+ -> S.Spacers Int
+ -> [TopCellSpec]
+topCellSpecs gFlds aFlds spcs = let
+ allFlds = topRowCells gFlds aFlds
+ cws = fmap (fmap ContentWidth) allFlds
+ merged = mergeWithSpacers cws spcs
+ tripler e (cw, maybeSpc) = (e, (fmap SpacerWidth maybeSpc), cw)
+ list = Fdbl.toList $ tripler <$> eTopRowCells <*> merged
+ toMaybe (e, maybeS, maybeC) = case maybeC of
+ Nothing -> Nothing
+ Just c -> Just (e, maybeS, c)
+ in catMaybes (map toMaybe list)
+
+
+-- | Merges a TopRowCells with a Spacers. Returns Maybes because
+-- totalQty has no spacer.
+mergeWithSpacers ::
+ TopRowCells a
+ -> S.Spacers b
+ -> TopRowCells (a, Maybe b)
+mergeWithSpacers t s = TopRowCells {
+ globalTransaction = (globalTransaction t, Just (S.globalTransaction s))
+ , revGlobalTransaction = (revGlobalTransaction t, Just (S.revGlobalTransaction s))
+ , globalPosting = (globalPosting t, Just (S.globalPosting s))
+ , revGlobalPosting = (revGlobalPosting t, Just (S.revGlobalPosting s))
+ , fileTransaction = (fileTransaction t, Just (S.fileTransaction s))
+ , revFileTransaction = (revFileTransaction t, Just (S.revFileTransaction s))
+ , filePosting = (filePosting t, Just (S.filePosting s))
+ , revFilePosting = (revFilePosting t, Just (S.revFilePosting s))
+ , filtered = (filtered t, Just (S.filtered s))
+ , revFiltered = (revFiltered t, Just (S.revFiltered s))
+ , sorted = (sorted t, Just (S.sorted s))
+ , revSorted = (revSorted t, Just (S.revSorted s))
+ , visible = (visible t, Just (S.visible s))
+ , revVisible = (revVisible t, Just (S.revVisible s))
+ , lineNum = (lineNum t, Just (S.lineNum s))
+ , date = (date t, Just (S.date s))
+ , flag = (flag t, Just (S.flag s))
+ , number = (number t, Just (S.number s))
+ , payee = (payee t, Just (S.payee s))
+ , account = (account t, Just (S.account s))
+ , postingDrCr = (postingDrCr t, Just (S.postingDrCr s))
+ , postingCmdty = (postingCmdty t, Just (S.postingCmdty s))
+ , postingQty = (postingQty t, Just (S.postingQty s))
+ , totalDrCr = (totalDrCr t, Just (S.totalDrCr s))
+ , totalCmdty = (totalCmdty t, Just (S.totalCmdty s))
+ , totalQty = (totalQty t, Nothing) }
+
+
+-- | Applied to a function that, when applied to the width of a cell,
+-- returns a cell filled with data, returns a Row with that cell.
+makeSpecificWidth
+ :: E.Changers -> Int -> ((M.PostMeta, L.Posting) -> Int -> (a, R.ColumnSpec))
+ -> (M.PostMeta, L.Posting) -> [Rb.Chunk]
+makeSpecificWidth ch w f i = R.row ch [c] where
+ (_, c) = f i w
+
+
+type Maker
+ = E.Changers
+ -> (M.PostMeta, L.Posting)
+ -> Int
+ -> ((E.Label, E.EvenOdd), R.ColumnSpec)
+
+makers :: Fields Maker
+makers = Fields tagsCell memoCell filenameCell
+
+-- | Applied to an Options, indicating which reports the user wants,
+-- returns a Fields (Maybe Maker) with a Maker in each respective
+-- field that the user wants to see.
+requestedMakers
+ :: E.Changers
+ -> F.Fields Bool
+ -> Fields (Maybe ((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)))
+requestedMakers ch allFlds =
+ let flds = bottomRowsFields allFlds
+ filler b mkr = if b then Just $ mkr ch else Nothing
+ in filler <$> flds <*> makers
+
+tagsCell
+ :: E.Changers
+ -> (M.PostMeta, L.Posting)
+ -> Int
+ -> ((E.Label, E.EvenOdd), R.ColumnSpec)
+tagsCell ch info w = (ts, cell) where
+ vn = M.visibleNum . fst $ info
+ cell = R.ColumnSpec R.LeftJustify (R.Width w) ts cs
+ eo = E.fromVisibleNum vn
+ ts = (E.Other, eo)
+ cs =
+ Fdbl.toList
+ . fmap toBit
+ . TF.unLines
+ . TF.wordWrap w
+ . TF.Words
+ . Seq.fromList
+ . map (X.cons '*')
+ . HT.textList
+ . Q.tags
+ . snd
+ $ info
+ md = E.getEvenOddLabelValue E.Other eo ch
+ toBit (TF.Words ws) = md . Rb.Chunk mempty $ t where
+ t = X.concat . intersperse (X.singleton ' ') . Fdbl.toList $ ws
+
+
+memoBits
+ :: E.Changers -> (E.Label, E.EvenOdd) -> L.Memo -> R.Width -> [Rb.Chunk]
+memoBits ch (lbl, eo) m (R.Width w) = cs where
+ cs = Fdbl.toList
+ . fmap toBit
+ . TF.unLines
+ . TF.wordWrap w
+ . TF.Words
+ . Seq.fromList
+ . X.words
+ . X.intercalate (X.singleton ' ')
+ . L.unMemo
+ $ m
+ md = E.getEvenOddLabelValue lbl eo ch
+ toBit (TF.Words ws) = md . Rb.Chunk mempty
+ $ (X.unwords . Fdbl.toList $ ws)
+
+
+memoCell
+ :: E.Changers -> (M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)
+memoCell ch info width = (ts, cell) where
+ w = R.Width width
+ vn = M.visibleNum . fst $ info
+ eo = E.fromVisibleNum vn
+ ts = (E.Other, eo)
+ cell = R.ColumnSpec R.LeftJustify w ts cs
+ mayPm = Q.postingMemo . snd $ info
+ mayTm = Q.transactionMemo . snd $ info
+ cs = case (mayPm, mayTm) of
+ (Nothing, Nothing) -> mempty
+ (Nothing, Just tm) -> memoBits ch ts tm w
+ (Just pm, Nothing) -> memoBits ch ts pm w
+ (Just pm, Just tm) -> memoBits ch ts pm w `mappend` memoBits ch ts tm w
+
+
+filenameCell
+ :: E.Changers -> (M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)
+filenameCell ch info width = (ts, cell) where
+ w = R.Width width
+ vn = M.visibleNum . fst $ info
+ eo = E.fromVisibleNum vn
+ ts = (E.Other, eo)
+ cell = R.ColumnSpec R.LeftJustify w ts cs
+ md = E.getEvenOddLabelValue E.Other eo ch
+ toBit n = md . Rb.Chunk mempty
+ . X.drop (max 0 (X.length n - width)) $ n
+ cs = case Q.filename . snd $ info of
+ Nothing -> []
+ Just fn -> [toBit . L.unFilename $ fn]
+
+
+data TopRowCells a = TopRowCells
+ { globalTransaction :: a
+ , revGlobalTransaction :: a
+ , globalPosting :: a
+ , revGlobalPosting :: a
+ , fileTransaction :: a
+ , revFileTransaction :: a
+ , filePosting :: a
+ , revFilePosting :: a
+ , filtered :: a
+ , revFiltered :: a
+ , sorted :: a
+ , revSorted :: a
+ , visible :: a
+ , revVisible :: a
+ , lineNum :: a
+ -- ^ The line number from the posting's metadata
+ , date :: a
+ , flag :: a
+ , number :: a
+ , payee :: a
+ , account :: a
+ , postingDrCr :: a
+ , postingCmdty :: a
+ , postingQty :: a
+ , totalDrCr :: a
+ , totalCmdty :: a
+ , totalQty :: a }
+ deriving (Show, Eq)
+
+topRowCells :: G.Fields a -> A.Fields a -> TopRowCells a
+topRowCells g a = TopRowCells
+ { globalTransaction = G.globalTransaction g
+ , revGlobalTransaction = G.revGlobalTransaction g
+ , globalPosting = G.globalPosting g
+ , revGlobalPosting = G.revGlobalPosting g
+ , fileTransaction = G.fileTransaction g
+ , revFileTransaction = G.revFileTransaction g
+ , filePosting = G.filePosting g
+ , revFilePosting = G.revFilePosting g
+ , filtered = G.filtered g
+ , revFiltered = G.revFiltered g
+ , sorted = G.sorted g
+ , revSorted = G.revSorted g
+ , visible = G.visible g
+ , revVisible = G.revVisible g
+ , lineNum = G.lineNum g
+ , date = G.date g
+ , flag = G.flag g
+ , number = G.number g
+ , payee = A.payee a
+ , account = A.account a
+ , postingDrCr = G.postingDrCr g
+ , postingCmdty = G.postingCmdty g
+ , postingQty = G.postingQty g
+ , totalDrCr = G.totalDrCr g
+ , totalCmdty = G.totalCmdty g
+ , totalQty = G.totalQty g }
+
+
+data ETopRowCells =
+ EGlobalTransaction
+ | ERevGlobalTransaction
+ | EGlobalPosting
+ | ERevGlobalPosting
+ | EFileTransaction
+ | ERevFileTransaction
+ | EFilePosting
+ | ERevFilePosting
+ | EFiltered
+ | ERevFiltered
+ | ESorted
+ | ERevSorted
+ | EVisible
+ | ERevVisible
+ | ELineNum
+ | EDate
+ | EFlag
+ | ENumber
+ | EPayee
+ | EAccount
+ | EPostingDrCr
+ | EPostingCmdty
+ | EPostingQty
+ | ETotalDrCr
+ | ETotalCmdty
+ | ETotalQty
+ deriving (Show, Eq, Enum)
+
+eTopRowCells :: TopRowCells ETopRowCells
+eTopRowCells = TopRowCells
+ { globalTransaction = EGlobalTransaction
+ , revGlobalTransaction = ERevGlobalTransaction
+ , globalPosting = EGlobalPosting
+ , revGlobalPosting = ERevGlobalPosting
+ , fileTransaction = EFileTransaction
+ , revFileTransaction = ERevFileTransaction
+ , filePosting = EFilePosting
+ , revFilePosting = ERevFilePosting
+ , filtered = EFiltered
+ , revFiltered = ERevFiltered
+ , sorted = ESorted
+ , revSorted = ERevSorted
+ , visible = EVisible
+ , revVisible = ERevVisible
+ , lineNum = ELineNum
+ , date = EDate
+ , flag = EFlag
+ , number = ENumber
+ , payee = EPayee
+ , account = EAccount
+ , postingDrCr = EPostingDrCr
+ , postingCmdty = EPostingCmdty
+ , postingQty = EPostingQty
+ , totalDrCr = ETotalDrCr
+ , totalCmdty = ETotalCmdty
+ , totalQty = ETotalQty }
+
+instance Functor TopRowCells where
+ fmap f t = TopRowCells
+ { globalTransaction = f (globalTransaction t)
+ , revGlobalTransaction = f (revGlobalTransaction t)
+ , globalPosting = f (globalPosting t)
+ , revGlobalPosting = f (revGlobalPosting t)
+ , fileTransaction = f (fileTransaction t)
+ , revFileTransaction = f (revFileTransaction t)
+ , filePosting = f (filePosting t)
+ , revFilePosting = f (revFilePosting t)
+ , filtered = f (filtered t)
+ , revFiltered = f (revFiltered t)
+ , sorted = f (sorted t)
+ , revSorted = f (revSorted t)
+ , visible = f (visible t)
+ , revVisible = f (revVisible t)
+ , lineNum = f (lineNum t)
+ , date = f (date t)
+ , flag = f (flag t)
+ , number = f (number t)
+ , payee = f (payee t)
+ , account = f (account t)
+ , postingDrCr = f (postingDrCr t)
+ , postingCmdty = f (postingCmdty t)
+ , postingQty = f (postingQty t)
+ , totalDrCr = f (totalDrCr t)
+ , totalCmdty = f (totalCmdty t)
+ , totalQty = f (totalQty t) }
+
+instance Applicative TopRowCells where
+ pure a = TopRowCells
+ { globalTransaction = a
+ , revGlobalTransaction = a
+ , globalPosting = a
+ , revGlobalPosting = a
+ , fileTransaction = a
+ , revFileTransaction = a
+ , filePosting = a
+ , revFilePosting = a
+ , filtered = a
+ , revFiltered = a
+ , sorted = a
+ , revSorted = a
+ , visible = a
+ , revVisible = a
+ , lineNum = a
+ , date = a
+ , flag = a
+ , number = a
+ , payee = a
+ , account = a
+ , postingDrCr = a
+ , postingCmdty = a
+ , postingQty = a
+ , totalDrCr = a
+ , totalCmdty = a
+ , totalQty = a }
+
+ ff <*> fa = TopRowCells
+ { globalTransaction = globalTransaction ff (globalTransaction fa)
+ , revGlobalTransaction = revGlobalTransaction ff (revGlobalTransaction fa)
+ , globalPosting = globalPosting ff (globalPosting fa)
+ , revGlobalPosting = revGlobalPosting ff (revGlobalPosting fa)
+ , fileTransaction = fileTransaction ff (fileTransaction fa)
+ , revFileTransaction = revFileTransaction ff (revFileTransaction fa)
+ , filePosting = filePosting ff (filePosting fa)
+ , revFilePosting = revFilePosting ff (revFilePosting fa)
+ , filtered = filtered ff (filtered fa)
+ , revFiltered = revFiltered ff (revFiltered fa)
+ , sorted = sorted ff (sorted fa)
+ , revSorted = revSorted ff (revSorted fa)
+ , visible = visible ff (visible fa)
+ , revVisible = revVisible ff (revVisible fa)
+ , lineNum = lineNum ff (lineNum fa)
+ , date = date ff (date fa)
+ , flag = flag ff (flag fa)
+ , number = number ff (number fa)
+ , payee = payee ff (payee fa)
+ , account = account ff (account fa)
+ , postingDrCr = postingDrCr ff (postingDrCr fa)
+ , postingCmdty = postingCmdty ff (postingCmdty fa)
+ , postingQty = postingQty ff (postingQty fa)
+ , totalDrCr = totalDrCr ff (totalDrCr fa)
+ , totalCmdty = totalCmdty ff (totalCmdty fa)
+ , totalQty = totalQty ff (totalQty fa) }
+
+instance Fdbl.Foldable TopRowCells where
+ foldr f z o =
+ f (globalTransaction o)
+ (f (revGlobalTransaction o)
+ (f (globalPosting o)
+ (f (revGlobalPosting o)
+ (f (fileTransaction o)
+ (f (revFileTransaction o)
+ (f (filePosting o)
+ (f (revFilePosting o)
+ (f (filtered o)
+ (f (revFiltered o)
+ (f (sorted o)
+ (f (revSorted o)
+ (f (visible o)
+ (f (revVisible o)
+ (f (lineNum o)
+ (f (date o)
+ (f (flag o)
+ (f (number o)
+ (f (payee o)
+ (f (account o)
+ (f (postingDrCr o)
+ (f (postingCmdty o)
+ (f (postingQty o)
+ (f (totalDrCr o)
+ (f (totalCmdty o)
+ (f (totalQty o) z)))))))))))))))))))))))))
+
+instance T.Traversable TopRowCells where
+ traverse f t =
+ TopRowCells
+ <$> f (globalTransaction t)
+ <*> f (revGlobalTransaction t)
+ <*> f (globalPosting t)
+ <*> f (revGlobalPosting t)
+ <*> f (fileTransaction t)
+ <*> f (revFileTransaction t)
+ <*> f (filePosting t)
+ <*> f (revFilePosting t)
+ <*> f (filtered t)
+ <*> f (revFiltered t)
+ <*> f (sorted t)
+ <*> f (revSorted t)
+ <*> f (visible t)
+ <*> f (revVisible t)
+ <*> f (lineNum t)
+ <*> f (date t)
+ <*> f (flag t)
+ <*> f (number t)
+ <*> f (payee t)
+ <*> f (account t)
+ <*> f (postingDrCr t)
+ <*> f (postingCmdty t)
+ <*> f (postingQty t)
+ <*> f (totalDrCr t)
+ <*> f (totalCmdty t)
+ <*> f (totalQty t)
+
diff --git a/lib/Penny/Cabin/Posts/Chunk.hs b/lib/Penny/Cabin/Posts/Chunk.hs
new file mode 100644
index 0000000..1055c26
--- /dev/null
+++ b/lib/Penny/Cabin/Posts/Chunk.hs
@@ -0,0 +1,150 @@
+module Penny.Cabin.Posts.Chunk (ChunkOpts(..), makeChunk) where
+
+import qualified Data.Foldable as Fdbl
+import Data.List (transpose)
+import Data.Maybe (isNothing, catMaybes)
+import qualified Penny.Cabin.Posts.Fields as F
+import qualified Penny.Cabin.Posts.Growers as G
+import qualified Penny.Cabin.Posts.Allocated as A
+import qualified Penny.Cabin.Posts.BottomRows as B
+import qualified Penny.Cabin.Posts.Spacers as S
+import qualified Penny.Cabin.Row as R
+import qualified Penny.Cabin.Scheme as E
+import qualified System.Console.Rainbow as Rb
+import qualified Penny.Cabin.Posts.Meta as M
+import qualified Penny.Lincoln as L
+import qualified Data.Text as X
+import qualified Penny.Cabin.Posts.Types as Ty
+
+data ChunkOpts = ChunkOpts
+ { dateFormat :: (M.PostMeta, L.Posting) -> X.Text
+ , qtyFormat :: L.Amount L.Qty -> X.Text
+ , fields :: F.Fields Bool
+ , subAccountLength :: A.SubAccountLength
+ , payeeAllocation :: A.Alloc
+ , accountAllocation :: A.Alloc
+ , spacers :: S.Spacers Int
+ , reportWidth :: Ty.ReportWidth
+ }
+
+growOpts :: ChunkOpts -> G.GrowOpts
+growOpts c = G.GrowOpts
+ { G.dateFormat = dateFormat c
+ , G.qtyFormat = qtyFormat c
+ , G.fields = fields c
+ }
+
+allocatedOpts :: ChunkOpts -> G.Fields (Maybe Int) -> A.AllocatedOpts
+allocatedOpts c g = A.AllocatedOpts
+ { A.fields = let f = fields c
+ in A.Fields { A.payee = F.payee f
+ , A.account = F.account f }
+ , A.subAccountLength = subAccountLength c
+ , A.allocations = A.Fields { A.payee = payeeAllocation c
+ , A.account = accountAllocation c }
+ , A.spacers = spacers c
+ , A.growerWidths = g
+ , A.reportWidth = reportWidth c
+ }
+
+bottomOpts ::
+ ChunkOpts
+ -> G.Fields (Maybe Int)
+ -> A.Fields (Maybe Int)
+ -> B.BottomOpts
+bottomOpts c g a = B.BottomOpts {
+ B.growingWidths = g
+ , B.allocatedWidths = a
+ , B.fields = fields c
+ , B.reportWidth = reportWidth c
+ , B.spacers = spacers c
+ }
+
+makeChunk
+ :: E.Changers
+ -> ChunkOpts
+ -> [(M.PostMeta, L.Posting)]
+ -> [Rb.Chunk]
+makeChunk ch c bs =
+ let fmapSnd = fmap (fmap snd)
+ fmapFst = fmap (fmap fst)
+ gFldW = fmap (fmap snd) gFlds
+ aFldW = fmapSnd aFlds
+ gFlds = G.growCells ch (growOpts c) bs
+ aFlds = A.payeeAndAcct ch (allocatedOpts c gFldW) bs
+ bFlds = B.bottomRows ch (bottomOpts c gFldW aFldW) bs
+ topCells = B.topRowCells (fmapFst gFlds) (fmap (fmap fst) aFlds)
+ withSpacers = B.mergeWithSpacers topCells (spacers c)
+ topRows = makeTopRows ch withSpacers
+ bottomRows = makeBottomRows bFlds
+ in makeAllRows topRows bottomRows
+
+
+topRowsCells
+ :: B.TopRowCells (Maybe [R.ColumnSpec], Maybe Int)
+ -> [[(R.ColumnSpec, Maybe R.ColumnSpec)]]
+topRowsCells t = let
+ toWithSpc (mayCs, maySp) = case mayCs of
+ Nothing -> Nothing
+ Just cs -> Just (makeSpacers cs maySp)
+ f mayPairList acc = case mayPairList of
+ Nothing -> acc
+ (Just pairList) -> pairList : acc
+ in transpose $ Fdbl.foldr f [] (fmap toWithSpc t)
+
+makeRow :: E.Changers -> [(R.ColumnSpec, Maybe R.ColumnSpec)] -> [Rb.Chunk]
+makeRow ch = R.row ch . foldr f [] where
+ f (c, mayC) acc = case mayC of
+ Nothing -> c:acc
+ Just spcr -> c:spcr:acc
+
+
+makeSpacers
+ :: [R.ColumnSpec]
+ -> Maybe Int
+ -> [(R.ColumnSpec, Maybe R.ColumnSpec)]
+makeSpacers cs mayI = case mayI of
+ Nothing -> map (\c -> (c, Nothing)) cs
+ Just i -> makeEvenOddSpacers cs i
+
+makeEvenOddSpacers
+ :: [R.ColumnSpec]
+ -> Int
+ -> [(R.ColumnSpec, Maybe R.ColumnSpec)]
+makeEvenOddSpacers cs i = let absI = abs i in
+ if absI == 0
+ then map (\c -> (c, Nothing)) cs
+ else let
+ spcrs = cycle [Just $ mkSpcr evenTs, Just $ mkSpcr oddTs]
+ mkSpcr ts = R.ColumnSpec R.LeftJustify (R.Width absI) ts []
+ evenTs = (E.Other, E.Even)
+ oddTs = (E.Other, E.Odd)
+ in zip cs spcrs
+
+makeTopRows
+ :: E.Changers
+ -> B.TopRowCells (Maybe [R.ColumnSpec], Maybe Int)
+ -> Maybe [[Rb.Chunk]]
+makeTopRows ch trc =
+ if Fdbl.all (isNothing . fst) trc
+ then Nothing
+ else Just $ map (makeRow ch) . topRowsCells $ trc
+
+
+makeBottomRows ::
+ B.Fields (Maybe [[Rb.Chunk]])
+ -> Maybe [[[Rb.Chunk]]]
+makeBottomRows flds =
+ if Fdbl.all isNothing flds
+ then Nothing
+ else Just . transpose . catMaybes . Fdbl.toList $ flds
+
+makeAllRows :: Maybe [[Rb.Chunk]] -> Maybe [[[Rb.Chunk]]] -> [Rb.Chunk]
+makeAllRows mayrs mayrrs = case (mayrs, mayrrs) of
+ (Nothing, Nothing) -> []
+ (Just rs, Nothing) -> concat rs
+ (Nothing, Just rrs) -> concat . concat $ rrs
+ (Just rs, Just rrs) -> concat $ zipWith f rs rrs where
+ f topRow botRows = concat [topRow, concat botRows]
+
+
diff --git a/lib/Penny/Cabin/Posts/Fields.hs b/lib/Penny/Cabin/Posts/Fields.hs
new file mode 100644
index 0000000..4cba45c
--- /dev/null
+++ b/lib/Penny/Cabin/Posts/Fields.hs
@@ -0,0 +1,199 @@
+-- | Fields that can appear in the Posts report.
+module Penny.Cabin.Posts.Fields where
+
+import Control.Applicative(Applicative(pure, (<*>)))
+import qualified Data.Foldable as F
+
+data Fields a = Fields
+ { globalTransaction :: a
+ , revGlobalTransaction :: a
+ , globalPosting :: a
+ , revGlobalPosting :: a
+ , fileTransaction :: a
+ , revFileTransaction :: a
+ , filePosting :: a
+ , revFilePosting :: a
+ , filtered :: a
+ , revFiltered :: a
+ , sorted :: a
+ , revSorted :: a
+ , visible :: a
+ , revVisible :: a
+ , lineNum :: a
+ , date :: a
+ , flag :: a
+ , number :: a
+ , payee :: a
+ , account :: a
+ , postingDrCr :: a
+ , postingCmdty :: a
+ , postingQty :: a
+ , totalDrCr :: a
+ , totalCmdty :: a
+ , totalQty :: a
+ , tags :: a
+ , memo :: a
+ , filename :: a
+ } deriving (Show, Eq)
+
+instance Functor Fields where
+ fmap f fa = Fields {
+ globalTransaction = f (globalTransaction fa)
+ , revGlobalTransaction = f (revGlobalTransaction fa)
+ , globalPosting = f (globalPosting fa)
+ , revGlobalPosting = f (revGlobalPosting fa)
+ , fileTransaction = f (fileTransaction fa)
+ , revFileTransaction = f (revFileTransaction fa)
+ , filePosting = f (filePosting fa)
+ , revFilePosting = f (revFilePosting fa)
+ , filtered = f (filtered fa)
+ , revFiltered = f (revFiltered fa)
+ , sorted = f (sorted fa)
+ , revSorted = f (revSorted fa)
+ , visible = f (visible fa)
+ , revVisible = f (revVisible fa)
+ , lineNum = f (lineNum fa)
+ , date = f (date fa)
+ , flag = f (flag fa)
+ , number = f (number fa)
+ , payee = f (payee fa)
+ , account = f (account fa)
+ , postingDrCr = f (postingDrCr fa)
+ , postingCmdty = f (postingCmdty fa)
+ , postingQty = f (postingQty fa)
+ , totalDrCr = f (totalDrCr fa)
+ , totalCmdty = f (totalCmdty fa)
+ , totalQty = f (totalQty fa)
+ , tags = f (tags fa)
+ , memo = f (memo fa)
+ , filename = f (filename fa) }
+
+instance Applicative Fields where
+ pure a = Fields {
+ globalTransaction = a
+ , revGlobalTransaction = a
+ , globalPosting = a
+ , revGlobalPosting = a
+ , fileTransaction = a
+ , revFileTransaction = a
+ , filePosting = a
+ , revFilePosting = a
+ , filtered = a
+ , revFiltered = a
+ , sorted = a
+ , revSorted = a
+ , visible = a
+ , revVisible = a
+ , lineNum = a
+ , date = a
+ , flag = a
+ , number = a
+ , payee = a
+ , account = a
+ , postingDrCr = a
+ , postingCmdty = a
+ , postingQty = a
+ , totalDrCr = a
+ , totalCmdty = a
+ , totalQty = a
+ , tags = a
+ , memo = a
+ , filename = a }
+
+ ff <*> fa = Fields {
+ globalTransaction = globalTransaction ff (globalTransaction fa)
+ , revGlobalTransaction = revGlobalTransaction ff
+ (revGlobalTransaction fa)
+ , globalPosting = globalPosting ff (globalPosting fa)
+ , revGlobalPosting = revGlobalPosting ff (revGlobalPosting fa)
+ , fileTransaction = fileTransaction ff (fileTransaction fa)
+ , revFileTransaction = revFileTransaction ff (revFileTransaction fa)
+ , filePosting = filePosting ff (filePosting fa)
+ , revFilePosting = revFilePosting ff (revFilePosting fa)
+ , filtered = filtered ff (filtered fa)
+ , revFiltered = revFiltered ff (revFiltered fa)
+ , sorted = sorted ff (sorted fa)
+ , revSorted = revSorted ff (revSorted fa)
+ , visible = visible ff (visible fa)
+ , revVisible = revVisible ff (revVisible fa)
+ , lineNum = lineNum ff (lineNum fa)
+ , date = date ff (date fa)
+ , flag = flag ff (flag fa)
+ , number = number ff (number fa)
+ , payee = payee ff (payee fa)
+ , account = account ff (account fa)
+ , postingDrCr = postingDrCr ff (postingDrCr fa)
+ , postingCmdty = postingCmdty ff (postingCmdty fa)
+ , postingQty = postingQty ff (postingQty fa)
+ , totalDrCr = totalDrCr ff (totalDrCr fa)
+ , totalCmdty = totalCmdty ff (totalCmdty fa)
+ , totalQty = totalQty ff (totalQty fa)
+ , tags = tags ff (tags fa)
+ , memo = memo ff (memo fa)
+ , filename = filename ff (filename fa) }
+
+instance F.Foldable Fields where
+ foldr f z t =
+ f (globalTransaction t)
+ (f (revGlobalTransaction t)
+ (f (globalPosting t)
+ (f (revGlobalPosting t)
+ (f (fileTransaction t)
+ (f (revFileTransaction t)
+ (f (filePosting t)
+ (f (revFilePosting t)
+ (f (filtered t)
+ (f (revFiltered t)
+ (f (sorted t)
+ (f (revSorted t)
+ (f (visible t)
+ (f (revVisible t)
+ (f (lineNum t)
+ (f (date t)
+ (f (flag t)
+ (f (number t)
+ (f (payee t)
+ (f (account t)
+ (f (postingDrCr t)
+ (f (postingCmdty t)
+ (f (postingQty t)
+ (f (totalDrCr t)
+ (f (totalCmdty t)
+ (f (totalQty t)
+ (f (tags t)
+ (f (memo t)
+ (f (filename t) z))))))))))))))))))))))))))))
+
+
+fieldNames :: Fields String
+fieldNames = Fields
+ { globalTransaction = "globalTransaction"
+ , revGlobalTransaction = "revGlobalTransaction"
+ , globalPosting = "globalPosting"
+ , revGlobalPosting = "revGlobalPosting"
+ , fileTransaction = "fileTransaction"
+ , revFileTransaction = "revFileTransaction"
+ , filePosting = "filePosting"
+ , revFilePosting = "revFilePosting"
+ , filtered = "filtered"
+ , revFiltered = "revFiltered"
+ , sorted = "sorted"
+ , revSorted = "revSorted"
+ , visible = "visible"
+ , revVisible = "revVisible"
+ , lineNum = "lineNum"
+ , date = "date"
+ , flag = "flag"
+ , number = "number"
+ , payee = "payee"
+ , account = "account"
+ , postingDrCr = "postingDrCr"
+ , postingCmdty = "postingCmdty"
+ , postingQty = "postingQty"
+ , totalDrCr = "totalDrCr"
+ , totalCmdty = "totalCmdty"
+ , totalQty = "totalQty"
+ , tags = "tags"
+ , memo = "memo"
+ , filename = "filename"
+ }
diff --git a/lib/Penny/Cabin/Posts/Growers.hs b/lib/Penny/Cabin/Posts/Growers.hs
new file mode 100644
index 0000000..880ecb1
--- /dev/null
+++ b/lib/Penny/Cabin/Posts/Growers.hs
@@ -0,0 +1,603 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Calculates cells that "grow to fit." These cells grow to fit the
+-- widest cell in the column. No information is ever truncated from
+-- these cells (what use is a truncated dollar amount?)
+module Penny.Cabin.Posts.Growers (
+ GrowOpts(..),
+ growCells, Fields(..), grownWidth,
+ eFields, EFields(..), pairWithSpacer) where
+
+import Control.Applicative((<$>), Applicative(pure, (<*>)))
+import qualified Data.Foldable as Fdbl
+import Data.Map (elems)
+import qualified Data.Map as Map
+import qualified Data.Semigroup as Semi
+import Data.Semigroup ((<>), mempty)
+import Data.Text (Text, pack, empty)
+import qualified Data.Text as X
+import qualified Penny.Cabin.Posts.Fields as F
+import qualified Penny.Cabin.Posts.Meta as M
+import qualified Penny.Cabin.Posts.Spacers as S
+import qualified Penny.Cabin.Row as R
+import qualified Penny.Cabin.Scheme as E
+import qualified Penny.Liberty as Ly
+import qualified Penny.Lincoln as L
+import qualified Penny.Lincoln.Queries as Q
+import qualified System.Console.Rainbow as Rb
+
+
+-- | All the options needed to grow the cells.
+data GrowOpts = GrowOpts
+ { dateFormat :: (M.PostMeta, L.Posting) -> X.Text
+ , qtyFormat :: L.Amount L.Qty -> X.Text
+ , fields :: F.Fields Bool
+ }
+
+-- | Grows the cells that will be GrowToFit cells in the report. First
+-- this function fills in all visible cells with text, but leaves the
+-- width undetermined. Then it determines the widest line in each
+-- column. Finally it adjusts each cell in the column so that it is
+-- that maximum width.
+--
+-- Returns a list of rows, and a Fields holding the width of each
+-- cell. Each of these widths will be at least 1; fields that were in
+-- the report but that ended up having no width are changed to
+-- Nothing.
+growCells
+ :: E.Changers
+ -> GrowOpts
+ -> [(M.PostMeta, L.Posting)]
+ -> Fields (Maybe ([R.ColumnSpec], Int))
+growCells ch o infos = toPair <$> wanted <*> growers where
+ toPair b gwr
+ | b =
+ let cs = map (gwr o ch) infos
+ w = Fdbl.foldl' f 0 cs where
+ f acc c = max acc (widestLine c)
+ cs' = map (sizer (R.Width w)) cs
+ in if w > 0 then Just (cs', w) else Nothing
+ | otherwise = Nothing
+ wanted = growingFields . fields $ o
+
+widestLine :: PreSpec -> Int
+widestLine (PreSpec _ _ bs) =
+ case bs of
+ [] -> 0
+ xs -> maximum . map (X.length . Rb._text) $ xs
+
+data PreSpec = PreSpec {
+ _justification :: R.Justification
+ , _padSpec :: (E.Label, E.EvenOdd)
+ , _bits :: [Rb.Chunk] }
+
+
+-- | Given a PreSpec and a width, create a ColumnSpec of the right
+-- size.
+sizer :: R.Width -> PreSpec -> R.ColumnSpec
+sizer w (PreSpec j ts bs) = R.ColumnSpec j w ts bs
+
+-- | Makes a left justified cell that is only one line long. The width
+-- is unset.
+oneLine :: E.Changers -> Text -> E.Label -> (M.PostMeta, L.Posting) -> PreSpec
+oneLine chgrs t lbl b =
+ let eo = E.fromVisibleNum . M.visibleNum . fst $ b
+ j = R.LeftJustify
+ md = E.getEvenOddLabelValue lbl eo chgrs
+ ck = [md $ Rb.Chunk mempty t]
+ in PreSpec j (lbl, eo) ck
+
+
+-- | Gets a Fields with each field filled with the function that fills
+-- the cells for that field.
+growers :: Fields (GrowOpts -> E.Changers -> (M.PostMeta, L.Posting) -> PreSpec)
+growers = Fields
+ { globalTransaction = const getGlobalTransaction
+ , revGlobalTransaction = const getRevGlobalTransaction
+ , globalPosting = const getGlobalPosting
+ , revGlobalPosting = const getRevGlobalPosting
+ , fileTransaction = const getFileTransaction
+ , revFileTransaction = const getRevFileTransaction
+ , filePosting = const getFilePosting
+ , revFilePosting = const getRevFilePosting
+ , filtered = const getFiltered
+ , revFiltered = const getRevFiltered
+ , sorted = const getSorted
+ , revSorted = const getRevSorted
+ , visible = const getVisible
+ , revVisible = const getRevVisible
+ , lineNum = const getLineNum
+ , date = \o ch -> getDate ch (dateFormat o)
+ , flag = const getFlag
+ , number = const getNumber
+ , postingDrCr = const getPostingDrCr
+ , postingCmdty = const getPostingCmdty
+ , postingQty = \o ch -> getPostingQty ch (qtyFormat o)
+ , totalDrCr = const getTotalDrCr
+ , totalCmdty = const getTotalCmdty
+ , totalQty = \o ch -> getTotalQty ch (qtyFormat o)
+ }
+
+-- | Make a left justified cell one line long that shows a serial.
+serialCellMaybe
+ :: E.Changers
+ -> (L.Posting -> Maybe Int)
+ -- ^ When applied to a Box, this function returns Just Int if the
+ -- box has a serial, or Nothing if not.
+
+ -> (M.PostMeta, L.Posting) -> PreSpec
+serialCellMaybe chgrs f b = oneLine chgrs t E.Other b
+ where
+ t = case f (snd b) of
+ Nothing -> X.empty
+ Just i -> X.pack . show $ i
+
+serialCell
+ :: E.Changers
+ -> (M.PostMeta -> Int)
+ -> (M.PostMeta, L.Posting) -> PreSpec
+serialCell chgrs f b = oneLine chgrs t E.Other b
+ where
+ t = pack . show . f . fst $ b
+
+getGlobalTransaction :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getGlobalTransaction chgrs =
+ serialCellMaybe chgrs (fmap (L.forward . L.unGlobalTransaction)
+ . Q.globalTransaction)
+
+getRevGlobalTransaction :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getRevGlobalTransaction chgrs =
+ serialCellMaybe chgrs (fmap (L.backward . L.unGlobalTransaction)
+ . Q.globalTransaction)
+
+getGlobalPosting :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getGlobalPosting chgrs =
+ serialCellMaybe chgrs (fmap (L.forward . L.unGlobalPosting)
+ . Q.globalPosting)
+
+getRevGlobalPosting :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getRevGlobalPosting chgrs =
+ serialCellMaybe chgrs (fmap (L.backward . L.unGlobalPosting)
+ . Q.globalPosting)
+
+getFileTransaction :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getFileTransaction chgrs =
+ serialCellMaybe chgrs (fmap (L.forward . L.unFileTransaction)
+ . Q.fileTransaction)
+
+getRevFileTransaction :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getRevFileTransaction chgrs =
+ serialCellMaybe chgrs (fmap (L.backward . L.unFileTransaction)
+ . Q.fileTransaction)
+
+getFilePosting :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getFilePosting chgrs =
+ serialCellMaybe chgrs (fmap (L.forward . L.unFilePosting)
+ . Q.filePosting)
+
+getRevFilePosting :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getRevFilePosting chgrs =
+ serialCellMaybe chgrs (fmap (L.backward . L.unFilePosting)
+ . Q.filePosting)
+
+getSorted :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getSorted chgrs =
+ serialCell chgrs (L.forward . Ly.unSortedNum . M.sortedNum)
+
+getRevSorted :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getRevSorted chgrs =
+ serialCell chgrs (L.backward . Ly.unSortedNum . M.sortedNum)
+
+getFiltered :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getFiltered chgrs =
+ serialCell chgrs (L.forward . Ly.unFilteredNum . M.filteredNum)
+
+getRevFiltered :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getRevFiltered chgrs =
+ serialCell chgrs (L.backward . Ly.unFilteredNum . M.filteredNum)
+
+getVisible :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getVisible chgrs =
+ serialCell chgrs (L.forward . M.unVisibleNum . M.visibleNum)
+
+getRevVisible :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getRevVisible chgrs =
+ serialCell chgrs (L.backward . M.unVisibleNum . M.visibleNum)
+
+
+getLineNum :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getLineNum chgrs b = oneLine chgrs t E.Other b where
+ lineTxt = pack . show . L.unPostingLine
+ t = maybe empty lineTxt (Q.postingLine . snd $ b)
+
+getDate :: E.Changers -> ((M.PostMeta, L.Posting) -> X.Text) -> (M.PostMeta, L.Posting) -> PreSpec
+getDate chgrs gd b = oneLine chgrs (gd b) E.Other b
+
+getFlag :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getFlag chgrs i = oneLine chgrs t E.Other i where
+ t = maybe empty L.text (Q.flag . snd $ i)
+
+getNumber :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getNumber chgrs i = oneLine chgrs t E.Other i where
+ t = maybe empty L.text (Q.number . snd $ i)
+
+dcTxt :: L.DrCr -> Text
+dcTxt L.Debit = X.singleton '<'
+dcTxt L.Credit = X.singleton '>'
+
+-- | Gives a one-line cell that is colored according to whether the
+-- posting is a debit or credit.
+coloredPostingCell :: E.Changers -> Text -> (M.PostMeta, L.Posting) -> PreSpec
+coloredPostingCell chgrs t i = PreSpec j (lbl, eo) [bit] where
+ j = R.LeftJustify
+ lbl = case Q.drCr . snd $ i of
+ L.Debit -> E.Debit
+ L.Credit -> E.Credit
+ eo = E.fromVisibleNum . M.visibleNum . fst $ i
+ md = E.getEvenOddLabelValue lbl eo chgrs
+ bit = md $ Rb.Chunk mempty t
+
+
+getPostingDrCr :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getPostingDrCr ch i = coloredPostingCell ch t i where
+ t = dcTxt . Q.drCr . snd $ i
+
+getPostingCmdty :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getPostingCmdty ch i = coloredPostingCell ch t i where
+ t = L.unCommodity . Q.commodity . snd $ i
+
+getPostingQty
+ :: E.Changers
+ -> (L.Amount L.Qty -> X.Text) -- ((M.PostMeta, L.Posting) -> X.Text)
+ -> (M.PostMeta, L.Posting)
+ -> PreSpec
+getPostingQty ch qf i = coloredPostingCell ch qtyStr i
+ where
+ qtyStr = case (L.entry . L.headEnt . snd . L.unPosting . snd $ i) of
+ Left qr -> L.showQtyRep . L.qty . L.amount $ qr
+ Right q -> qf . L.amount $ q
+
+getTotalDrCr :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getTotalDrCr ch i =
+ let vn = M.visibleNum . fst $ i
+ ps = (lbl, eo)
+ dc = Q.drCr . snd $ i
+ lbl = E.dcToLbl dc
+ eo = E.fromVisibleNum vn
+ bal = L.unBalance . M.balance . fst $ i
+ md = E.getEvenOddLabelValue lbl eo ch
+ bits =
+ if Map.null bal
+ then [md "--"]
+ else let mkChk e = E.bottomLineToDrCr e eo ch
+ in fmap mkChk . elems $ bal
+ j = R.LeftJustify
+ in PreSpec j ps bits
+
+getTotalCmdty :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec
+getTotalCmdty ch i =
+ let vn = M.visibleNum . fst $ i
+ j = R.RightJustify
+ ps = (lbl, eo)
+ dc = Q.drCr . snd $ i
+ eo = E.fromVisibleNum vn
+ lbl = E.dcToLbl dc
+ bal = Map.toList . L.unBalance . M.balance . fst $ i
+ preChunks = E.balancesToCmdtys ch eo bal
+ in PreSpec j ps preChunks
+
+getTotalQty
+ :: E.Changers
+ -> (L.Amount L.Qty -> X.Text)
+ -> (M.PostMeta, L.Posting)
+ -> PreSpec
+getTotalQty ch balFmt i =
+ let vn = M.visibleNum . fst $ i
+ j = R.LeftJustify
+ dc = Q.drCr . snd $ i
+ ps = (E.dcToLbl dc, eo)
+ eo = E.fromVisibleNum vn
+ bal = Map.toList . L.unBalance . M.balance . fst $ i
+ preChunks = E.balanceToQtys ch balFmt eo bal
+ in PreSpec j ps preChunks
+
+growingFields :: F.Fields Bool -> Fields Bool
+growingFields f = Fields
+ { globalTransaction = F.globalTransaction f
+ , revGlobalTransaction = F.revGlobalTransaction f
+ , globalPosting = F.globalPosting f
+ , revGlobalPosting = F.revGlobalPosting f
+ , fileTransaction = F.fileTransaction f
+ , revFileTransaction = F.revFileTransaction f
+ , filePosting = F.filePosting f
+ , revFilePosting = F.revFilePosting f
+ , filtered = F.filtered f
+ , revFiltered = F.revFiltered f
+ , sorted = F.sorted f
+ , revSorted = F.revSorted f
+ , visible = F.visible f
+ , revVisible = F.revVisible f
+ , lineNum = F.lineNum f
+ , date = F.date f
+ , flag = F.flag f
+ , number = F.number f
+ , postingDrCr = F.postingDrCr f
+ , postingCmdty = F.postingCmdty f
+ , postingQty = F.postingQty f
+ , totalDrCr = F.totalDrCr f
+ , totalCmdty = F.totalCmdty f
+ , totalQty = F.totalQty f }
+
+-- | All growing fields, as an ADT.
+data EFields =
+ EGlobalTransaction
+ | ERevGlobalTransaction
+ | EGlobalPosting
+ | ERevGlobalPosting
+ | EFileTransaction
+ | ERevFileTransaction
+ | EFilePosting
+ | ERevFilePosting
+ | EFiltered
+ | ERevFiltered
+ | ESorted
+ | ERevSorted
+ | EVisible
+ | ERevVisible
+ | ELineNum
+ | EDate
+ | EFlag
+ | ENumber
+ | EPostingDrCr
+ | EPostingCmdty
+ | EPostingQty
+ | ETotalDrCr
+ | ETotalCmdty
+ | ETotalQty
+ deriving (Show, Eq, Ord, Enum)
+
+-- | Returns a Fields where each record has its corresponding EField.
+eFields :: Fields EFields
+eFields = Fields
+ { globalTransaction = EGlobalTransaction
+ , revGlobalTransaction = ERevGlobalTransaction
+ , globalPosting = EGlobalPosting
+ , revGlobalPosting = ERevGlobalPosting
+ , fileTransaction = EFileTransaction
+ , revFileTransaction = ERevFileTransaction
+ , filePosting = EFilePosting
+ , revFilePosting = ERevFilePosting
+ , filtered = EFiltered
+ , revFiltered = ERevFiltered
+ , sorted = ESorted
+ , revSorted = ERevSorted
+ , visible = EVisible
+ , revVisible = ERevVisible
+ , lineNum = ELineNum
+ , date = EDate
+ , flag = EFlag
+ , number = ENumber
+ , postingDrCr = EPostingDrCr
+ , postingCmdty = EPostingCmdty
+ , postingQty = EPostingQty
+ , totalDrCr = ETotalDrCr
+ , totalCmdty = ETotalCmdty
+ , totalQty = ETotalQty }
+
+-- | All growing fields.
+data Fields a = Fields
+ { globalTransaction :: a
+ , revGlobalTransaction :: a
+ , globalPosting :: a
+ , revGlobalPosting :: a
+ , fileTransaction :: a
+ , revFileTransaction :: a
+ , filePosting :: a
+ , revFilePosting :: a
+ , filtered :: a
+ , revFiltered :: a
+ , sorted :: a
+ , revSorted :: a
+ , visible :: a
+ , revVisible :: a
+ , lineNum :: a
+ -- ^ The line number from the posting's metadata
+ , date :: a
+ , flag :: a
+ , number :: a
+ , postingDrCr :: a
+ , postingCmdty :: a
+ , postingQty :: a
+ , totalDrCr :: a
+ , totalCmdty :: a
+ , totalQty :: a }
+ deriving (Show, Eq)
+
+instance Fdbl.Foldable Fields where
+ foldr f z i =
+ f (globalTransaction i)
+ (f (revGlobalTransaction i)
+ (f (globalPosting i)
+ (f (revGlobalPosting i)
+ (f (fileTransaction i)
+ (f (revFileTransaction i)
+ (f (filePosting i)
+ (f (revFilePosting i)
+ (f (filtered i)
+ (f (revFiltered i)
+ (f (sorted i)
+ (f (revSorted i)
+ (f (visible i)
+ (f (revVisible i)
+ (f (lineNum i)
+ (f (date i)
+ (f (flag i)
+ (f (number i)
+ (f (postingDrCr i)
+ (f (postingCmdty i)
+ (f (postingQty i)
+ (f (totalDrCr i)
+ (f (totalCmdty i)
+ (f (totalQty i) z)))))))))))))))))))))))
+
+instance Functor Fields where
+ fmap f i = Fields
+ { globalTransaction = f (globalTransaction i)
+ , revGlobalTransaction = f (revGlobalTransaction i)
+ , globalPosting = f (globalPosting i)
+ , revGlobalPosting = f (revGlobalPosting i)
+ , fileTransaction = f (fileTransaction i)
+ , revFileTransaction = f (revFileTransaction i)
+ , filePosting = f (filePosting i)
+ , revFilePosting = f (revFilePosting i)
+ , filtered = f (filtered i)
+ , revFiltered = f (revFiltered i)
+ , sorted = f (sorted i)
+ , revSorted = f (revSorted i)
+ , visible = f (visible i)
+ , revVisible = f (revVisible i)
+ , lineNum = f (lineNum i)
+ , date = f (date i)
+ , flag = f (flag i)
+ , number = f (number i)
+ , postingDrCr = f (postingDrCr i)
+ , postingCmdty = f (postingCmdty i)
+ , postingQty = f (postingQty i)
+ , totalDrCr = f (totalDrCr i)
+ , totalCmdty = f (totalCmdty i)
+ , totalQty = f (totalQty i) }
+
+instance Applicative Fields where
+ pure a = Fields
+ { globalTransaction = a
+ , revGlobalTransaction = a
+ , globalPosting = a
+ , revGlobalPosting = a
+ , fileTransaction = a
+ , revFileTransaction = a
+ , filePosting = a
+ , revFilePosting = a
+ , filtered = a
+ , revFiltered = a
+ , sorted = a
+ , revSorted = a
+ , visible = a
+ , revVisible = a
+ , lineNum = a
+ , date = a
+ , flag = a
+ , number = a
+ , postingDrCr = a
+ , postingCmdty = a
+ , postingQty = a
+ , totalDrCr = a
+ , totalCmdty = a
+ , totalQty = a }
+
+ fl <*> fa = Fields
+ { globalTransaction = globalTransaction fl (globalTransaction fa)
+ , revGlobalTransaction = revGlobalTransaction fl (revGlobalTransaction fa)
+ , globalPosting = globalPosting fl (globalPosting fa)
+ , revGlobalPosting = revGlobalPosting fl (revGlobalPosting fa)
+ , fileTransaction = fileTransaction fl (fileTransaction fa)
+ , revFileTransaction = revFileTransaction fl (revFileTransaction fa)
+ , filePosting = filePosting fl (filePosting fa)
+ , revFilePosting = revFilePosting fl (revFilePosting fa)
+ , filtered = filtered fl (filtered fa)
+ , revFiltered = revFiltered fl (revFiltered fa)
+ , sorted = sorted fl (sorted fa)
+ , revSorted = revSorted fl (revSorted fa)
+ , visible = visible fl (visible fa)
+ , revVisible = revVisible fl (revVisible fa)
+ , lineNum = lineNum fl (lineNum fa)
+ , date = date fl (date fa)
+ , flag = flag fl (flag fa)
+ , number = number fl (number fa)
+ , postingDrCr = postingDrCr fl (postingDrCr fa)
+ , postingCmdty = postingCmdty fl (postingCmdty fa)
+ , postingQty = postingQty fl (postingQty fa)
+ , totalDrCr = totalDrCr fl (totalDrCr fa)
+ , totalCmdty = totalCmdty fl (totalCmdty fa)
+ , totalQty = totalQty fl (totalQty fa) }
+
+-- | Pairs data from a Fields with its matching spacer field. The
+-- spacer field is returned in a Maybe because the TotalQty field does
+-- not have a spacer.
+pairWithSpacer :: Fields a -> S.Spacers b -> Fields (a, Maybe b)
+pairWithSpacer f s = Fields {
+ globalTransaction = (globalTransaction f, Just (S.globalTransaction s))
+ , revGlobalTransaction = (revGlobalTransaction f, Just (S.revGlobalTransaction s))
+ , globalPosting = (globalPosting f, Just (S.globalPosting s))
+ , revGlobalPosting = (revGlobalPosting f, Just (S.revGlobalPosting s))
+ , fileTransaction = (fileTransaction f, Just (S.fileTransaction s))
+ , revFileTransaction = (revFileTransaction f, Just (S.revFileTransaction s))
+ , filePosting = (filePosting f, Just (S.filePosting s))
+ , revFilePosting = (revFilePosting f, Just (S.revFilePosting s))
+ , filtered = (filtered f, Just (S.filtered s))
+ , revFiltered = (revFiltered f, Just (S.revFiltered s))
+ , sorted = (sorted f, Just (S.sorted s))
+ , revSorted = (revSorted f, Just (S.revSorted s))
+ , visible = (visible f, Just (S.visible s))
+ , revVisible = (revVisible f, Just (S.revVisible s))
+ , lineNum = (lineNum f, Just (S.lineNum s))
+ , date = (date f, Just (S.date s))
+ , flag = (flag f, Just (S.flag s))
+ , number = (number f, Just (S.number s))
+ , postingDrCr = (postingDrCr f, Just (S.postingDrCr s))
+ , postingCmdty = (postingCmdty f, Just (S.postingCmdty s))
+ , postingQty = (postingQty f, Just (S.postingQty s))
+ , totalDrCr = (totalDrCr f, Just (S.totalDrCr s))
+ , totalCmdty = (totalCmdty f, Just (S.totalCmdty s))
+ , totalQty = (totalQty f, Nothing ) }
+
+-- | Reduces a set of Fields to a single value.
+reduce :: Semi.Semigroup s => Fields s -> s
+reduce f =
+ globalTransaction f
+ <> revGlobalTransaction f
+ <> globalPosting f
+ <> revGlobalPosting f
+ <> fileTransaction f
+ <> revFileTransaction f
+ <> filePosting f
+ <> revFilePosting f
+ <> filtered f
+ <> revFiltered f
+ <> sorted f
+ <> revSorted f
+ <> visible f
+ <> revVisible f
+ <> lineNum f
+ <> date f
+ <> flag f
+ <> number f
+ <> postingDrCr f
+ <> postingCmdty f
+ <> postingQty f
+ <> totalDrCr f
+ <> totalCmdty f
+ <> totalQty f
+
+-- | Compute the width of all Grown cells, including any applicable
+-- spacer cells.
+grownWidth ::
+ Fields (Maybe Int)
+ -> S.Spacers Int
+ -> Int
+grownWidth fs ss =
+ Semi.getSum
+ . reduce
+ . fmap Semi.Sum
+ . fmap fieldWidth
+ $ pairWithSpacer fs ss
+
+-- | Compute the field width of a single field and its spacer. The
+-- first element of the tuple is the field width, if present; the
+-- second element of the tuple is the width of the spacer. If there is
+-- no field, returns 0.
+fieldWidth :: (Maybe Int, Maybe Int) -> Int
+fieldWidth (m1, m2) = case m1 of
+ Nothing -> 0
+ Just i1 -> case m2 of
+ Just i2 -> if i2 > 0 then i1 + i2 else i1
+ Nothing -> i1
+
diff --git a/lib/Penny/Cabin/Posts/Meta.hs b/lib/Penny/Cabin/Posts/Meta.hs
new file mode 100644
index 0000000..f58f1a7
--- /dev/null
+++ b/lib/Penny/Cabin/Posts/Meta.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE RankNTypes #-}
+module Penny.Cabin.Posts.Meta
+ ( M.VisibleNum(M.unVisibleNum)
+ , PostMeta(filteredNum, sortedNum, visibleNum, balance)
+ , toBoxList
+ ) where
+
+import Data.List (mapAccumL)
+import qualified Penny.Lincoln as L
+import qualified Penny.Lincoln.Queries as Q
+import qualified Penny.Liberty as Ly
+import qualified Penny.Cabin.Meta as M
+import qualified Penny.Cabin.Options as CO
+import qualified Data.Prednote.Pdct as Pe
+import Data.Monoid (mempty, mappend)
+
+data PostMeta = PostMeta
+ { filteredNum :: Ly.FilteredNum
+ , sortedNum :: Ly.SortedNum
+ , visibleNum :: M.VisibleNum
+ , balance :: L.Balance }
+ deriving Show
+
+
+addMetadata
+ :: [(L.Balance, (Ly.LibertyMeta, L.Posting))]
+ -> [(PostMeta, L.Posting)]
+addMetadata = L.serialItems f where
+ f ser (bal, (lm, p)) = (pm, p)
+ where
+ pm = PostMeta
+ { filteredNum = Ly.filteredNum lm
+ , sortedNum = Ly.sortedNum lm
+ , visibleNum = M.VisibleNum ser
+ , balance = bal
+ }
+
+-- | Adds appropriate metadata, including the running balance, to a
+-- list of Box. Because all posts are incorporated into the running
+-- balance, first calculates the running balance for all posts. Then,
+-- removes posts we're not interested in by applying the predicate and
+-- the post-filter. Finally, adds on the metadata, which will include
+-- the VisibleNum.
+toBoxList
+ :: CO.ShowZeroBalances
+ -> Pe.Pdct (Ly.LibertyMeta, L.Posting)
+ -- ^ Removes posts from the report if applying this function to the
+ -- post returns a value other than Just True. Posts removed still
+ -- affect the running balance.
+
+ -> [Ly.PostFilterFn]
+ -- ^ Applies these post-filters to the list of posts that results
+ -- from applying the predicate above. Might remove more
+ -- postings. Postings removed still affect the running balance.
+
+ -> [(Ly.LibertyMeta, L.Posting)]
+ -> [(PostMeta, L.Posting)]
+toBoxList szb pdct pff
+ = addMetadata
+ . Ly.processPostFilters pff
+ . filter (Pe.rBool . flip Pe.evaluate pdct . snd)
+ . addBalances szb
+
+addBalances
+ :: CO.ShowZeroBalances
+ -> [(a, L.Posting)]
+ -> [(L.Balance, (a, L.Posting))]
+addBalances szb = snd . mapAccumL (balanceAccum szb) mempty
+
+balanceAccum
+ :: CO.ShowZeroBalances
+ -> L.Balance
+ -> (a, L.Posting)
+ -> (L.Balance, (L.Balance, (a, L.Posting)))
+balanceAccum (CO.ShowZeroBalances szb) balOld (x, po) =
+ let balThis = either L.entryToBalance L.entryToBalance
+ . Q.entry $ po
+ balNew = mappend balOld balThis
+ balNoZeroes = L.removeZeroCommodities balNew
+ bal' = if szb then balNew else balNoZeroes
+ po' = (bal', (x, po))
+ in (bal', po')
+
diff --git a/lib/Penny/Cabin/Posts/Parser.hs b/lib/Penny/Cabin/Posts/Parser.hs
new file mode 100644
index 0000000..c08b41e
--- /dev/null
+++ b/lib/Penny/Cabin/Posts/Parser.hs
@@ -0,0 +1,286 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Penny.Cabin.Posts.Parser
+ ( State(..)
+ , allSpecs
+ , Error
+ , VerboseFilter(..)
+ , ShowExpression(..)
+ ) where
+
+import Control.Applicative ((<$>), pure, (<*>),
+ Applicative)
+import qualified Control.Monad.Exception.Synchronous as Ex
+import Data.Char (toLower)
+import qualified Data.Foldable as Fdbl
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as X
+import qualified System.Console.MultiArg.Combinator as C
+import qualified System.Console.MultiArg as MA
+
+import qualified Penny.Cabin.Parsers as P
+import qualified Penny.Cabin.Posts.Fields as F
+import qualified Penny.Cabin.Posts.Types as Ty
+import qualified Penny.Cabin.Options as CO
+import qualified Penny.Liberty as Ly
+import qualified Data.Prednote.Expressions as Exp
+import qualified Data.Prednote.Pdct as Pt
+import qualified Penny.Lincoln as L
+import qualified Penny.Shield as S
+import qualified Text.Matchers as M
+
+newtype VerboseFilter = VerboseFilter { unVerboseFilter :: Bool }
+ deriving (Eq, Show)
+
+newtype ShowExpression = ShowExpression { unShowExpression :: Bool }
+ deriving (Eq, Show)
+
+data State = State
+ { sensitive :: M.CaseSensitive
+ , factory :: L.Factory
+ , tokens :: [Exp.Token (Ly.LibertyMeta, L.Posting)]
+ , postFilter :: [Ly.PostFilterFn]
+ , fields :: F.Fields Bool
+ , width :: Ty.ReportWidth
+ , showZeroBalances :: CO.ShowZeroBalances
+ , exprDesc :: Exp.ExprDesc
+ , verboseFilter :: VerboseFilter
+ , showExpression :: ShowExpression
+ }
+
+type Error = X.Text
+
+allSpecs
+ :: S.Runtime -> [MA.OptSpec (State -> Ex.Exceptional Error State)]
+allSpecs rt =
+ operand rt
+ ++ boxFilters
+ ++ parsePostFilter
+ ++ (map (fmap (pure .)) matcherSelect)
+ ++ (map (fmap (pure .)) caseSelect)
+ ++ (map (fmap (pure .)) operator)
+ ++ map (fmap (pure .)) parseExprType
+ ++ [ parseWidth
+ , showField
+ , hideField
+ , fmap (pure .) showAllFields
+ , fmap (pure .) hideAllFields
+ , fmap (pure .) parseZeroBalances
+ , fmap (pure .) parseShowExpression
+ , fmap (pure .) parseVerboseFilter
+ ]
+
+
+operand
+ :: S.Runtime
+ -> [MA.OptSpec (State -> Ex.Exceptional Error State)]
+operand rt = map (fmap f) (Ly.operandSpecs (S.currentTime rt))
+ where
+ f lyFn st = do
+ let cs = sensitive st
+ fty = factory st
+ g <- lyFn cs fty
+ let g' = Pt.boxPdct snd g
+ ts' = tokens st ++ [Exp.operand g']
+ return $ st { tokens = ts' }
+
+
+-- | Processes a option for box-level serials.
+optBoxSerial
+ :: String
+ -- ^ Serial name
+
+ -> (Ly.LibertyMeta -> Int)
+ -- ^ Pulls the serial from the PostMeta
+
+ -> C.OptSpec (State -> Ex.Exceptional Error State)
+
+optBoxSerial nm f = C.OptSpec [nm] "" (C.TwoArg g)
+ where
+ g a1 a2 st = do
+ i <- Ly.parseInt a2
+ let getPd = Pt.compareBy (X.pack . show $ i)
+ ("serial " <> X.pack nm) cmp
+ cmp l = compare (f . fst $ l) i
+ pd <- Ly.parseComparer a1 getPd
+ let tok = Exp.operand pd
+ return $ st { tokens = tokens st ++ [tok] }
+
+optFilteredNum :: C.OptSpec (State -> Ex.Exceptional Error State)
+optFilteredNum = optBoxSerial "filtered" f
+ where
+ f = L.forward . Ly.unFilteredNum . Ly.filteredNum
+
+optRevFilteredNum :: C.OptSpec (State -> Ex.Exceptional Error State)
+optRevFilteredNum = optBoxSerial "revFiltered" f
+ where
+ f = L.backward . Ly.unFilteredNum . Ly.filteredNum
+
+optSortedNum :: C.OptSpec (State -> Ex.Exceptional Error State)
+optSortedNum = optBoxSerial "sorted" f
+ where
+ f = L.forward . Ly.unSortedNum . Ly.sortedNum
+
+optRevSortedNum :: C.OptSpec (State -> Ex.Exceptional Error State)
+optRevSortedNum = optBoxSerial "revSorted" f
+ where
+ f = L.backward . Ly.unSortedNum . Ly.sortedNum
+
+boxFilters :: [C.OptSpec (State -> Ex.Exceptional Error State)]
+boxFilters =
+ [ optFilteredNum
+ , optRevFilteredNum
+ , optSortedNum
+ , optRevSortedNum
+ ]
+
+
+parsePostFilter :: [C.OptSpec (State -> Ex.Exceptional Error State)]
+parsePostFilter = [fmap f optH, fmap f optT]
+ where
+ (optH, optT) = Ly.postFilterSpecs
+ f exc st = fmap g exc
+ where
+ g pff = st { postFilter = postFilter st ++ [pff] }
+
+
+matcherSelect :: [C.OptSpec (State -> State)]
+matcherSelect = map (fmap f) Ly.matcherSelectSpecs
+ where
+ f mf st = st { factory = mf }
+
+
+caseSelect :: [C.OptSpec (State -> State)]
+caseSelect = map (fmap f) Ly.caseSelectSpecs
+ where
+ f cs st = st { sensitive = cs }
+
+operator :: [C.OptSpec (State -> State)]
+operator = map (fmap f) Ly.operatorSpecs
+ where
+ f oo st = st { tokens = tokens st ++ [oo] }
+
+parseWidth :: C.OptSpec (State -> Ex.Exceptional Error State)
+parseWidth = C.OptSpec ["width"] "" (C.OneArg f)
+ where
+ f a1 st = do
+ i <- Ly.parseInt a1
+ return $ st { width = Ty.ReportWidth i }
+
+parseField :: String -> Ex.Exceptional Error (F.Fields Bool)
+parseField str =
+ let lower = map toLower str
+ checkField s =
+ if (map toLower s) == lower
+ then (s, True)
+ else (s, False)
+ flds = checkField <$> F.fieldNames
+ in case checkFields flds of
+ Ex.Exception e -> case e of
+ NoMatchingFields -> Ex.throw
+ $ "no field matches the name \"" <> X.pack str <> "\"\n"
+ MultipleMatchingFields ts -> Ex.throw
+ $ "multiple fields match the name \"" <> X.pack str
+ <> "\" matches: " <> mtchs <> "\n"
+ where
+ mtchs = X.intercalate " "
+ . map (\x -> "\"" <> x <> "\"")
+ $ ts
+ Ex.Success g -> return g
+
+
+-- | Turns a field on if it is True.
+fieldOn ::
+ F.Fields Bool
+ -- ^ Fields as seen so far
+
+ -> F.Fields Bool
+ -- ^ Record that should have one True element indicating a field
+ -- name seen on the command line; other elements should be False
+
+ -> F.Fields Bool
+ -- ^ Fields as seen so far, with new field added
+
+fieldOn old new = (||) <$> old <*> new
+
+-- | Turns off a field if it is True.
+fieldOff ::
+ F.Fields Bool
+ -- ^ Fields seen so far
+
+ -> F.Fields Bool
+ -- ^ Record that should have one True element indicating a field
+ -- name seen on the command line; other elements should be False
+
+ -> F.Fields Bool
+ -- ^ Fields as seen so far, with new field added
+
+fieldOff old new = f <$> old <*> new
+ where
+ f o False = o
+ f _ True = False
+
+showField :: C.OptSpec (State -> Ex.Exceptional Error State)
+showField = C.OptSpec ["show"] "" (C.OneArg f)
+ where
+ f a1 st = do
+ fl <- parseField a1
+ let newFl = fieldOn (fields st) fl
+ return $ st { fields = newFl }
+
+hideField :: C.OptSpec (State -> Ex.Exceptional Error State)
+hideField = C.OptSpec ["hide"] "" (C.OneArg f)
+ where
+ f a1 st = do
+ fl <- parseField a1
+ let newFl = fieldOff (fields st) fl
+ return $ st { fields = newFl }
+
+showAllFields :: C.OptSpec (State -> State)
+showAllFields = C.OptSpec ["show-all"] "" (C.NoArg f)
+ where
+ f st = st {fields = pure True}
+
+hideAllFields :: C.OptSpec (State -> State)
+hideAllFields = C.OptSpec ["hide-all"] "" (C.NoArg f)
+ where
+ f st = st {fields = pure False}
+
+parseZeroBalances :: C.OptSpec (State -> State)
+parseZeroBalances = fmap f P.zeroBalances
+ where
+ f szb st = st { showZeroBalances = szb }
+
+parseExprType :: [C.OptSpec (State -> State)]
+parseExprType = map (fmap f) [Ly.parseInfix, Ly.parseRPN]
+ where
+ f d st = st { exprDesc = d }
+
+parseShowExpression :: C.OptSpec (State -> State)
+parseShowExpression = fmap f Ly.showExpression
+ where
+ f _ st = st { showExpression = ShowExpression True }
+
+parseVerboseFilter :: C.OptSpec (State -> State)
+parseVerboseFilter = fmap f Ly.verboseFilter
+ where
+ f _ st = st { verboseFilter = VerboseFilter True }
+
+data BadFieldError
+ = NoMatchingFields
+ | MultipleMatchingFields [Text]
+ deriving Show
+
+-- | Checks the fields with the True value to ensure there is only one.
+checkFields ::
+ F.Fields (String, Bool)
+ -> Ex.Exceptional BadFieldError (F.Fields Bool)
+checkFields fs =
+ let f (s, b) ls = if b then s:ls else ls
+ in case Fdbl.foldr f [] fs of
+ [] -> Ex.throw NoMatchingFields
+ _:[] -> return (snd <$> fs)
+ ms -> Ex.throw . MultipleMatchingFields . map X.pack $ ms
+
+
diff --git a/lib/Penny/Cabin/Posts/Spacers.hs b/lib/Penny/Cabin/Posts/Spacers.hs
new file mode 100644
index 0000000..d96a3df
--- /dev/null
+++ b/lib/Penny/Cabin/Posts/Spacers.hs
@@ -0,0 +1,32 @@
+-- | Spacer fields in the report. They don't contain any data; they
+-- just provide whitespace. Each spacer immediately follows the named
+-- field.
+module Penny.Cabin.Posts.Spacers where
+
+data Spacers a = Spacers
+ { globalTransaction :: a
+ , revGlobalTransaction :: a
+ , globalPosting :: a
+ , revGlobalPosting :: a
+ , fileTransaction :: a
+ , revFileTransaction :: a
+ , filePosting :: a
+ , revFilePosting :: a
+ , filtered :: a
+ , revFiltered :: a
+ , sorted :: a
+ , revSorted :: a
+ , visible :: a
+ , revVisible :: a
+ , lineNum :: a
+ , date :: a
+ , flag :: a
+ , number :: a
+ , payee :: a
+ , account :: a
+ , postingDrCr :: a
+ , postingCmdty :: a
+ , postingQty :: a
+ , totalDrCr :: a
+ , totalCmdty :: a
+ } deriving (Show, Eq)
diff --git a/lib/Penny/Cabin/Posts/Types.hs b/lib/Penny/Cabin/Posts/Types.hs
new file mode 100644
index 0000000..9e3e5b1
--- /dev/null
+++ b/lib/Penny/Cabin/Posts/Types.hs
@@ -0,0 +1,4 @@
+module Penny.Cabin.Posts.Types where
+
+newtype ReportWidth = ReportWidth { unReportWidth :: Int }
+ deriving (Eq, Show, Ord)
diff --git a/lib/Penny/Cabin/Row.hs b/lib/Penny/Cabin/Row.hs
new file mode 100644
index 0000000..d5d330f
--- /dev/null
+++ b/lib/Penny/Cabin/Row.hs
@@ -0,0 +1,140 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Displays a single on-screen row. A row may contain multiple
+-- screen lines and multiple columns.
+--
+-- This module only deals with a single row at a time. Each cell in
+-- the row can have more than one screen line; this module will make
+-- sure that the cells have appropriate padding on the bottom so that
+-- the row appears nicely. This module will also justify each cell so
+-- that its left side or right side is ragged; however, you first have
+-- to specify how wide you want the cell to be.
+--
+-- This module is a little dumber than you might first think it could
+-- be. For instance it would be possible to write a function that
+-- takes a number of rows and automatically justifies all the cells by
+-- finding the widest cell in a column. Indeed I might eventually
+-- write such a function because it might be useful in, for example,
+-- the multi-commodity balance report. However, such a function would
+-- not be useful in all cases; in particular, the Posts report is very
+-- complicated to lay out, and the automatic function described above
+-- would not do the right thing.
+--
+-- So this module offers some useful automation, even if it is at a
+-- level that is apparently lower that what is possible. Thus the
+-- present 'row' function likely will not change, even if eventually I
+-- add a 'table' function that automatically justifies many rows.
+module Penny.Cabin.Row (
+ Justification(LeftJustify, RightJustify),
+ ColumnSpec(ColumnSpec, justification, width, padSpec, bits),
+ Width(Width, unWidth),
+ row ) where
+
+import Data.List (transpose)
+import Data.Monoid (mempty)
+import qualified Data.Text as X
+import qualified Penny.Cabin.Scheme as E
+import qualified System.Console.Rainbow as R
+
+-- | How to justify cells. LeftJustify leaves the right side
+-- ragged. RightJustify leaves the left side ragged.
+data Justification =
+ LeftJustify
+ | RightJustify
+ deriving Show
+
+-- | A cell of text output. You tell the cell how to justify itself
+-- and how wide it is. You also tell it the background colors to
+-- use. The cell will be appropriately justified (that is, text
+-- aligned between left and right margins) and padded (with lines of
+-- blank text added on the bottom as needed) when joined with other
+-- cells into a Row.
+data ColumnSpec =
+ ColumnSpec { justification :: Justification
+ , width :: Width
+ , padSpec :: (E.Label, E.EvenOdd)
+ , bits :: [R.Chunk] }
+
+newtype JustifiedCell = JustifiedCell (R.Chunk, R.Chunk)
+
+data JustifiedColumn = JustifiedColumn {
+ justifiedCells :: [JustifiedCell]
+ , _justifiedWidth :: Width
+ , _justifiedPadSpec :: (E.Label, E.EvenOdd) }
+
+newtype PaddedColumns = PaddedColumns [[JustifiedCell]]
+newtype CellsByRow = CellsByRow [[JustifiedCell]]
+newtype CellRowsWithNewlines = CellRowsWithNewlines [[JustifiedCell]]
+newtype Width = Width { unWidth :: Int }
+ deriving (Eq, Ord, Show)
+
+justify
+ :: Width
+ -> Justification
+ -> E.Label
+ -> E.EvenOdd
+ -> E.Changers
+ -> R.Chunk
+ -> JustifiedCell
+justify (Width w) j l eo chgrs pc = JustifiedCell (left, right)
+ where
+ origWidth = X.length . R._text $ pc
+ pad = E.getEvenOddLabelValue l eo chgrs . R.Chunk mempty $ t
+ t = X.replicate (max 0 (w - origWidth)) (X.singleton ' ')
+ (left, right) = case j of
+ LeftJustify -> (pc, pad)
+ RightJustify -> (pad, pc)
+
+newtype Height = Height Int
+ deriving (Show, Eq, Ord)
+
+height :: [[a]] -> Height
+height xs = case xs of
+ [] -> Height 0
+ ls -> Height . maximum . map length $ ls
+
+row :: E.Changers -> [ColumnSpec] -> [R.Chunk]
+row chgrs =
+ concat
+ . concat
+ . toBits
+ . toCellRowsWithNewlines
+ . toCellsByRow
+ . bottomPad chgrs
+ . map (justifiedColumn chgrs)
+
+justifiedColumn :: E.Changers -> ColumnSpec -> JustifiedColumn
+justifiedColumn chgrs (ColumnSpec j w (l, eo) bs)
+ = JustifiedColumn cs w (l, eo)
+ where
+ cs = map (justify w j l eo chgrs) bs
+
+bottomPad :: E.Changers -> [JustifiedColumn] -> PaddedColumns
+bottomPad chgrs jcs = PaddedColumns pcs where
+ justCells = map justifiedCells jcs
+ (Height h) = height justCells
+ pcs = map toPaddedColumn jcs
+ toPaddedColumn (JustifiedColumn cs (Width w) (lbl, eo)) =
+ let l = length cs
+ nPads = max 0 $ h - l
+ pad = E.getEvenOddLabelValue lbl eo chgrs . R.Chunk mempty $ t
+ t = X.replicate w (X.singleton ' ')
+ pads = replicate nPads $ JustifiedCell (mempty, pad)
+ in cs ++ pads
+
+
+toCellsByRow :: PaddedColumns -> CellsByRow
+toCellsByRow (PaddedColumns cs) = CellsByRow (transpose cs)
+
+
+toCellRowsWithNewlines :: CellsByRow -> CellRowsWithNewlines
+toCellRowsWithNewlines (CellsByRow bs) =
+ CellRowsWithNewlines bs' where
+ bs' = foldr f [] bs
+ newline = JustifiedCell (mempty, "\n")
+ f cells acc = (cells ++ [newline]) : acc
+
+
+toBits :: CellRowsWithNewlines -> [[[R.Chunk]]]
+toBits (CellRowsWithNewlines cs) = map (map toB) cs where
+ toB (JustifiedCell (c1, c2)) = [c1, c2]
+
diff --git a/lib/Penny/Cabin/Scheme.hs b/lib/Penny/Cabin/Scheme.hs
new file mode 100644
index 0000000..c087b3a
--- /dev/null
+++ b/lib/Penny/Cabin/Scheme.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Cabin color schemes
+--
+-- Each element of a Cabin report identifies what it is--a debit on an
+-- even line, a credit on an odd line, etc. The user can have several
+-- color schemes; the scheme contains color assignments for 8 and 256
+-- color terminals. This allows the use of different schemes for light
+-- and dark terminals or for any other reason.
+
+module Penny.Cabin.Scheme where
+
+import Data.Monoid (mempty)
+import qualified Penny.Cabin.Meta as M
+import qualified Penny.Lincoln as L
+import qualified Data.Text as X
+import qualified System.Console.Rainbow as R
+
+data Label
+ = Debit
+ | Credit
+ | Zero
+ | Other
+ deriving (Eq, Ord, Show)
+
+data EvenOdd = Even | Odd deriving (Eq, Ord, Show)
+
+data Labels a = Labels
+ { debit :: a
+ , credit :: a
+ , zero :: a
+ , other :: a
+ } deriving Show
+
+getLabelValue :: Label -> Labels a -> a
+getLabelValue l ls = case l of
+ Debit -> debit ls
+ Credit -> credit ls
+ Zero -> zero ls
+ Other -> other ls
+
+data EvenAndOdd a = EvenAndOdd
+ { eoEven :: a
+ , eoOdd :: a
+ } deriving Show
+
+type Changers = Labels (EvenAndOdd (R.Chunk -> R.Chunk))
+
+data Scheme = Scheme
+ { name :: String
+ -- ^ The name of this scheme. How it will be identified on the
+ -- command line.
+
+ , description :: String
+ -- ^ A brief (one-line) description of what this scheme is, such
+ -- as @for dark background terminals@
+
+ , changers :: Changers
+ } deriving Show
+
+
+getEvenOdd :: EvenOdd -> EvenAndOdd a -> a
+getEvenOdd eo eao = case eo of
+ Even -> eoEven eao
+ Odd -> eoOdd eao
+
+getEvenOddLabelValue
+ :: Label
+ -> EvenOdd
+ -> Labels (EvenAndOdd a)
+ -> a
+getEvenOddLabelValue l eo ls =
+ getEvenOdd eo (getLabelValue l ls)
+
+fromVisibleNum :: M.VisibleNum -> EvenOdd
+fromVisibleNum vn =
+ let s = M.unVisibleNum vn in
+ if even . L.forward $ s then Even else Odd
+
+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
+ where
+ (c, md) = case bl of
+ L.Zero -> ("--", getEvenOddLabelValue Zero eo chgrs)
+ L.NonZero (L.Column clmDrCr _) -> case clmDrCr of
+ L.Debit -> ("<", getEvenOddLabelValue Debit eo chgrs)
+ L.Credit -> (">", getEvenOddLabelValue Credit eo chgrs)
+
+
+balancesToCmdtys
+ :: Changers
+ -> EvenOdd
+ -> [(L.Commodity, L.BottomLine)]
+ -> [R.Chunk]
+balancesToCmdtys chgrs eo ls =
+ if null ls
+ then [getEvenOddLabelValue Zero eo chgrs $ "--"]
+ else map (bottomLineToCmdty chgrs eo) ls
+
+bottomLineToCmdty
+ :: Changers
+ -> EvenOdd
+ -> (L.Commodity, L.BottomLine)
+ -> R.Chunk
+bottomLineToCmdty chgrs eo (cy, bl) = md c
+ where
+ c = R.Chunk mempty . L.unCommodity $ cy
+ lbl = case bl of
+ L.Zero -> Zero
+ L.NonZero (L.Column clmDrCr _) -> dcToLbl clmDrCr
+ md = getEvenOddLabelValue lbl eo chgrs
+
+balanceToQtys
+ :: Changers
+ -> (L.Amount L.Qty -> X.Text)
+ -> EvenOdd
+ -> [(L.Commodity, L.BottomLine)]
+ -> [R.Chunk]
+balanceToQtys chgrs getTxt eo ls =
+ if null ls
+ then let md = getEvenOddLabelValue Zero eo chgrs
+ in [md "--"]
+ else map (bottomLineToQty chgrs getTxt eo) ls
+
+
+bottomLineToQty
+ :: Changers
+ -> (L.Amount L.Qty -> X.Text)
+ -> EvenOdd
+ -> (L.Commodity, L.BottomLine)
+ -> R.Chunk
+bottomLineToQty chgrs getTxt eo (cy, bl) = md (R.Chunk mempty t)
+ where
+ (lbl, t) = case bl of
+ L.Zero -> (Zero, X.pack "--")
+ L.NonZero (L.Column clmDrCr qt) ->
+ (dcToLbl clmDrCr, getTxt (L.Amount qt cy))
+ md = getEvenOddLabelValue lbl eo chgrs
+
diff --git a/lib/Penny/Cabin/Scheme/Schemes.hs b/lib/Penny/Cabin/Scheme/Schemes.hs
new file mode 100644
index 0000000..7a93088
--- /dev/null
+++ b/lib/Penny/Cabin/Scheme/Schemes.hs
@@ -0,0 +1,87 @@
+-- | Some schemes you can use.
+
+module Penny.Cabin.Scheme.Schemes where
+
+import Data.Monoid ( (<>) )
+import qualified Penny.Cabin.Scheme as E
+import qualified System.Console.Rainbow as R
+
+-- | The light color scheme. You can change various values below to
+-- affect the color scheme.
+light :: E.Scheme
+light = E.Scheme "light" "for light background terminals"
+ lightLabels
+
+lightLabels :: E.Labels (E.EvenAndOdd (R.Chunk -> R.Chunk))
+lightLabels = E.Labels
+ { E.debit = E.EvenAndOdd { E.eoEven = lightDebit lightEvenTextSpec
+ , E.eoOdd = lightDebit lightOddTextSpec }
+ , E.credit = E.EvenAndOdd { E.eoEven = lightCredit lightEvenTextSpec
+ , E.eoOdd = lightCredit lightOddTextSpec }
+ , E.zero = E.EvenAndOdd { E.eoEven = lightZero lightEvenTextSpec
+ , E.eoOdd = lightZero lightOddTextSpec }
+ , E.other = E.EvenAndOdd { E.eoEven = lightEvenTextSpec
+ , E.eoOdd = lightOddTextSpec }
+ }
+
+lightEvenTextSpec :: R.Chunk -> R.Chunk
+lightEvenTextSpec = id
+
+lightOddTextSpec :: R.Chunk -> R.Chunk
+lightOddTextSpec = (<> (R.c8_b_default <> R.c256_b_255))
+
+lightDebit :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk
+lightDebit f c = f c <> R.c8_f_magenta <> R.c256_f_52
+
+lightCredit :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk
+lightCredit f c = f c <> R.c8_f_cyan <> R.c256_f_21
+
+lightZero :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk
+lightZero f c = f c <> R.c8_f_black <> R.c256_f_0
+
+-- | The dark color scheme. You can change various values below to
+-- affect the color scheme.
+dark :: E.Scheme
+dark = E.Scheme "dark" "for dark background terminals"
+ darkLabels
+
+darkLabels :: E.Labels (E.EvenAndOdd (R.Chunk -> R.Chunk))
+darkLabels = E.Labels
+ { E.debit = E.EvenAndOdd { E.eoEven = darkDebit darkEvenTextSpec
+ , E.eoOdd = darkDebit darkOddTextSpec }
+ , E.credit = E.EvenAndOdd { E.eoEven = darkCredit darkEvenTextSpec
+ , E.eoOdd = darkCredit darkOddTextSpec }
+ , E.zero = E.EvenAndOdd { E.eoEven = darkZero darkEvenTextSpec
+ , E.eoOdd = darkZero darkOddTextSpec }
+ , E.other = E.EvenAndOdd { E.eoEven = darkEvenTextSpec
+ , E.eoOdd = darkOddTextSpec }
+ }
+
+darkEvenTextSpec :: R.Chunk -> R.Chunk
+darkEvenTextSpec = id
+
+darkOddTextSpec :: R.Chunk -> R.Chunk
+darkOddTextSpec = (<> (R.c8_b_default <> R.c256_b_235))
+
+darkDebit :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk
+darkDebit f c = f c <> R.c8_f_magenta <> R.c256_f_208
+
+darkCredit :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk
+darkCredit f c = f c <> R.c8_f_cyan <> R.c256_f_45
+
+darkZero :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk
+darkZero f c = f c <> R.c8_f_white <> R.c256_f_15
+
+-- | Plain scheme has no colors at all.
+plain :: E.Scheme
+plain = E.Scheme "plain" "uses default terminal colors"
+ plainLabels
+
+plainLabels :: E.Labels (E.EvenAndOdd (R.Chunk -> R.Chunk))
+plainLabels = E.Labels
+ { E.debit = E.EvenAndOdd id id
+ , E.credit = E.EvenAndOdd id id
+ , E.zero = E.EvenAndOdd id id
+ , E.other = E.EvenAndOdd id id
+ }
+
diff --git a/lib/Penny/Cabin/TextFormat.hs b/lib/Penny/Cabin/TextFormat.hs
new file mode 100644
index 0000000..7bdbff8
--- /dev/null
+++ b/lib/Penny/Cabin/TextFormat.hs
@@ -0,0 +1,173 @@
+module Penny.Cabin.TextFormat (
+ Lines(Lines, unLines),
+ Words(Words, unWords),
+ CharsPerLine(unCharsPerLine),
+ txtWords,
+ wordWrap,
+ Target(Target, unTarget),
+ Shortest(Shortest, unShortest),
+ shorten) where
+
+import qualified Control.Monad.Trans.State as St
+import qualified Data.Foldable as F
+import Data.Sequence ((|>), ViewR((:>)), ViewL((:<)))
+import qualified Data.Sequence as S
+import qualified Data.Text as X
+import qualified Data.Traversable as T
+
+data Lines = Lines { unLines :: S.Seq Words } deriving Show
+data Words = Words { unWords :: S.Seq X.Text } deriving Show
+newtype CharsPerLine =
+ CharsPerLine { unCharsPerLine :: Int } deriving Show
+
+-- | Splits a blank-separated text into words.
+txtWords :: X.Text -> Words
+txtWords = Words . S.fromList . X.words
+
+-- | Wraps a sequence of words into a sequence of lines, where each
+-- line is no more than a given maximum number of characters long.
+--
+-- If the maximum number of characters per line is less than 1,
+-- returns a Lines that is empty.
+--
+-- An individual word will be split across multiple lines only if that
+-- word is too long to fit into a single line. No hyphenation is done;
+-- the word is simply broken across two lines.
+wordWrap :: Int -> Words -> Lines
+wordWrap l (Words wsq) =
+ if l < 1
+ then Lines (S.empty)
+ else F.foldl f (Lines S.empty) wsq where
+ f (Lines sws) w = let
+ (back, ws) = case S.viewr sws of
+ S.EmptyR -> (S.empty, Words S.empty)
+ (b :> x) -> (b, x)
+ in case addWord l ws w of
+ (Just ws') -> Lines $ back |> ws'
+ Nothing ->
+ if X.length w > l
+ then addPartialWords l (Lines sws) w
+ else Lines (back |> ws |> (Words (S.singleton w)))
+
+lenWords :: Words -> Int
+lenWords (Words s) = case S.length s of
+ 0 -> 0
+ l -> (F.sum . fmap X.length $ s) + (l - 1)
+
+-- | Adds a word to a Words, but only if it will not make the Words
+-- exceed the given length.
+addWord :: Int -> Words -> X.Text -> Maybe Words
+addWord l (Words ws) w =
+ let words' = Words (ws |> w)
+ in if lenWords words' > l
+ then Nothing
+ else Just words'
+
+-- | Adds a word to a Words. If the word is too long to fit, breaks it
+-- and adds the longest portion possible. Returns the new Words, and a
+-- Text with the part of the word that was not added (if any; if all
+-- of the word was added, return an empty Text.)
+addPartialWord :: Int -> Words -> X.Text -> (Words, X.Text)
+addPartialWord l (Words ws) t = case addWord l (Words ws) t of
+ (Just ws') -> (ws', X.empty)
+ Nothing ->
+ let maxChars =
+ if S.null ws then l
+ else max 0 (l - lenWords (Words ws) - 1)
+ (begin, end) = X.splitAt maxChars t
+ in (Words (if X.null begin then ws else ws |> begin), end)
+
+addPartialWords :: Int -> Lines -> X.Text -> Lines
+addPartialWords l (Lines wsq) t = let
+ (back, ws) = case S.viewr wsq of
+ S.EmptyR -> (S.empty, Words S.empty)
+ (b :> x) -> (b, x)
+ (rw, rt) = addPartialWord l ws t
+ in if X.null rt
+ then Lines (back |> rw)
+ else addPartialWords l (Lines (back |> rw |> Words (S.empty))) rt
+
+newtype Target = Target { unTarget :: Int } deriving Show
+newtype Shortest = Shortest { unShortest :: Int } deriving Show
+
+-- | Takes a list of words and shortens it so that it fits in the
+-- space allotted. You specify the minimum length for each word, x. It
+-- will shorten the farthest left word first, until it is only x
+-- characters long; then it will shorten the next word until it is
+-- only x characters long, etc. This proceeds until all words are just
+-- x characters long. Then words are shortened to one
+-- character. Then the leftmost words are deleted as necessary.
+--
+-- Assumes that the words will be printed with a separator, which
+-- matters when lengths are calculated.
+shorten :: Shortest -> Target -> Words -> Words
+shorten (Shortest s) (Target t) wsa@(Words wsq) = let
+ nToRemove = max (lenWords wsa - t) 0
+ (allWords, _) = shortenUntilOne s nToRemove wsq
+ in stripWordsUntil t (Words allWords)
+
+-- | Shorten a word by x characters or until it is y characters long,
+-- whichever comes first. Returns the word and the number of
+-- characters removed.
+shortenUntil :: Int -> Int -> X.Text -> (X.Text, Int)
+shortenUntil by shortest t = let
+ removable = max (X.length t - shortest) 0
+ toRemove = min removable (max by 0)
+ prefix = X.length t - toRemove
+ in (X.take prefix t, toRemove)
+
+-- | Shortens a word until it is x characters long or by the number of
+-- characters indicated in the state, whichever is less. Subtracts the
+-- number of characters removed from the state.
+shortenSt :: Int -> X.Text -> St.State Int X.Text
+shortenSt shortest t = do
+ by <- St.get
+ let (r, nRemoved) = shortenUntil by shortest t
+ St.put (by - nRemoved)
+ return r
+
+-- | Shortens each word in a list, from left to right, until a
+-- particular number of characters have been reduced or until each
+-- word is x characters long, whichever happens first. Returns the new
+-- list and the number of characters that still need to be reduced.
+shortenEachInList ::
+ T.Traversable t
+ => Int -- ^ Shortest word length
+ -> Int -- ^ Total number to remove
+ -> t X.Text
+ -> (t X.Text, Int)
+shortenEachInList shortest by ts = (r, left) where
+ k = T.mapM (shortenSt shortest) ts
+ (r, left) = St.runState k by
+
+shortenUntilOne ::
+ T.Traversable t
+ => Int -- ^ Shortest word length to start with
+ -> Int -- ^ Total number of characters to remove
+ -> t X.Text
+ -> (t X.Text, Int)
+shortenUntilOne shortest by ts = let
+ r@(ts', left) = shortenEachInList shortest by ts
+ in if shortest == 1 || left == 0
+ then r
+ else shortenUntilOne (pred shortest) left ts'
+
+-- | Eliminates words until the length of the words, as indicated by
+-- lenWords, is less than or equal to the value given.
+stripWordsUntil :: Int -> Words -> Words
+stripWordsUntil i wsa@(Words ws) = case S.viewl ws of
+ S.EmptyL -> Words (S.empty)
+ (_ :< rest) ->
+ if lenWords wsa <= (max i 0)
+ then wsa
+ else stripWordsUntil (max i 0) (Words rest)
+
+
+--
+-- Testing
+--
+_words :: Words
+_words = Words . S.fromList . map X.pack $ ws where
+ ws = [ "these", "are", "fragilisticwonderfulgood",
+ "good", "", "x", "xy", "xyza",
+ "longlonglongword" ]
diff --git a/lib/Penny/Copper.hs b/lib/Penny/Copper.hs
new file mode 100644
index 0000000..e04b13d
--- /dev/null
+++ b/lib/Penny/Copper.hs
@@ -0,0 +1,232 @@
+-- | Copper - the Penny parser.
+--
+-- The parse functions in this module only accept lists of files
+-- rather than individual files because in order to correctly assign
+-- the global serials a single function must be able to see all the
+-- transactions, not just the transactions in a single file.
+--
+-- Some notes about Copper and performance:
+--
+-- Running Penny on the datasets I typically use takes about two
+-- seconds. This does not seem very long on paper, and indeed it isn't
+-- very long, but it would be nice if this were
+-- instantaneous. Profiles consistently show that the most
+-- time-consuming part of running Penny is the Parsec parse of the
+-- incoming data. After eliminating the Parsec phase, the profile is
+-- not showing any parts of the program whose runtime could be
+-- shortened easily--the time is spent scattered amongst many
+-- functions.
+--
+-- So the clear place to hunt for performance improvements is in the
+-- Parsec phase. And, indeed, I have tried many things to improve this
+-- phase. I tried using a parser based on Happy and Alex rather than
+-- Parsec; this code is tagged in the Git repository, though it is so
+-- old that many of the other data structures in Penny have since
+-- changed. Happy and Alex did not yield any significant performance
+-- improvement. As I recall, between Parsec and Happy/Alex, one was a
+-- little faster but used more memory, though I can't remember which
+-- was which.
+--
+-- The problem with using Happy and Alex is that it is a bit harder to
+-- test and to maintain. Each Parsec parser is freestanding and can be
+-- tested on its own; doing this with Happy would be harder. Happy
+-- parsers also are not written in Haskell, though I'm not sure this
+-- is a disadvantage. And, of course an advantage to Happy is that it
+-- warns you if your grammar is ambiguous; Parsec will only reveal
+-- this through usage or through meticulous testing.
+--
+-- It isn't worth using Happy/Alex in Penny because of the negligible
+-- performance difference. Parsec has much better error messages than
+-- Happy/Alex, which turns out to be critically important.
+--
+-- Another thing I tried was using Attoparsec, which bills itself as
+-- being faster. The speed improvements were negligible, and
+-- Parsec error messages are much better than those in Attoparsec. I
+-- would have been willing to maintain a Parsec and an Attoparsec
+-- parser if the latter were faster. Penny could parse with Attoparsec
+-- first and, if that fails, use Parsec and use its error message. But
+-- Attoparsec was so negligibly faster that I did not think this
+-- worthwhile.
+--
+-- Another thing I tried was using the @binary@ package to serialize
+-- the data in binary form. This shaved off a fair amont of run
+-- time. But Penny still did not feel instantaneous--run time probably
+-- dropped by about 40 percent, which is significant. The big
+-- disadvantage to using binary is that you then need to get
+-- plain-text ledger files into binary form, save them, and then use
+-- the binary form if it is up to date. Doing this manually imposes a
+-- big burden on the user to convert plain text to binary. Doing it
+-- automatically could work but would be a lot of code. And then, you
+-- would need to factor converstion time into the performance
+-- comparison. Again, not worth it for the performance improvement
+-- involved.
+--
+-- Probably the best performance improvement would come from putting
+-- the whole ledger into SQLite. This would, however, run into the
+-- same problems that exist with using a binary format: you need to
+-- convert from plain text, or perhaps write an editor to change the
+-- binary natively. I'm not eager to write an editor (we already have
+-- Emacs). Furthermore, using SQLite would likely require a
+-- significant re-engineering of Penny.
+--
+-- So, Penny continues to use the simplest, most obvious solution--a
+-- Parsec parser--not from inertia or because Parsec is the default
+-- choice; rather, Parsec so far has proven to be the best solution to
+-- this problem.
+module Penny.Copper
+ (
+ -- * Convenience functions to read and parse files
+ open
+
+ -- * Types for things found in ledger files
+ , module Penny.Copper.Interface
+
+ -- * Rendering
+ , R.item
+
+
+ ) where
+
+import Control.Arrow (second)
+import qualified Data.Traversable as Tr
+import qualified Penny.Copper.Parsec as CP
+import qualified Penny.Steel.Sums as S
+import Penny.Copper.Interface
+import qualified Penny.Copper.Interface as I
+
+import qualified Penny.Lincoln as L
+import qualified Penny.Copper.Render as R
+
+-- | Reads and parses the given files. If any of the files is @-@,
+-- reads standard input. If the list of files is empty, reads standard
+-- input. IO errors are not caught. Parse errors are printed to
+-- standard error and the program will exit with a failure.
+open :: [String] -> IO [I.LedgerItem]
+open ss
+ | null ss = fmap (parsedToWrapped . (:[])) CP.parseStdinOnly
+ | otherwise = fmap parsedToWrapped $ mapM CP.parseFromFilename ss
+
+addFilePosting
+ :: Tr.Traversable f
+ => [S.S4 (a, f b) x y z]
+ -> [S.S4 (a, f (L.FilePosting, b)) x y z]
+addFilePosting = L.serialNestedItems f where
+ f i = case i of
+ S.S4a (a, ctnr) ->
+ Right ( ctnr
+ , (\ser ii -> (L.FilePosting ser, ii))
+ , (\res -> S.S4a (a, res))
+ )
+ S.S4b x -> Left (S.S4b x)
+ S.S4c x -> Left (S.S4c x)
+ S.S4d x -> Left (S.S4d x)
+
+addFileTransaction
+ :: [S.S4 (a, b) x y z]
+ -> [S.S4 ((L.FileTransaction, a), b) x y z]
+addFileTransaction = L.serialSomeItems f where
+ f i = case i of
+ S.S4a (a, b) -> Right (\ser -> S.S4a ((L.FileTransaction ser, a), b))
+ S.S4b x -> Left (S.S4b x)
+ S.S4c x -> Left (S.S4c x)
+ S.S4d x -> Left (S.S4d x)
+
+addGlobalTransaction
+ :: [S.S4 (a, b) x y z]
+ -> [S.S4 ((L.GlobalTransaction, a), b) x y z]
+addGlobalTransaction = L.serialSomeItems f where
+ f i = case i of
+ S.S4a (a, b) -> Right (\ser -> S.S4a ((L.GlobalTransaction ser, a), b))
+ S.S4b x -> Left (S.S4b x)
+ S.S4c x -> Left (S.S4c x)
+ S.S4d x -> Left (S.S4d x)
+
+addGlobalPosting
+ :: Tr.Traversable f
+ => [S.S4 (a, f b) x y z]
+ -> [S.S4 (a, f (L.GlobalPosting, b)) x y z]
+addGlobalPosting = L.serialNestedItems f where
+ f i = case i of
+ S.S4a (a, ctnr) ->
+ Right ( ctnr
+ , (\ser ii -> (L.GlobalPosting ser, ii))
+ , (\res -> S.S4a (a, res))
+ )
+ S.S4b x -> Left (S.S4b x)
+ S.S4c x -> Left (S.S4c x)
+ S.S4d x -> Left (S.S4d x)
+
+addFilename
+ :: L.Filename
+ -> [S.S4 (a, b) x y z]
+ -> [S.S4 ((L.Filename, a), b) x y z]
+addFilename fn = map f where
+ f i = case i of
+ S.S4a (a, b) -> S.S4a ((fn, a), b)
+ S.S4b x -> S.S4b x
+ S.S4c x -> S.S4c x
+ S.S4d x -> S.S4d x
+
+addFileSerials
+ :: Tr.Traversable f
+ => [S.S4 (a, f b) x y z]
+ -> [S.S4 ((L.FileTransaction, a), f (L.FilePosting, b)) x y z]
+addFileSerials
+ = addFilePosting
+ . addFileTransaction
+
+addFileData
+ :: Tr.Traversable f
+ => (L.Filename, [S.S4 (a, f b) x y z])
+ -> [S.S4 ((L.Filename, (L.FileTransaction, a)), f (L.FilePosting, b)) x y z]
+addFileData = uncurry addFilename . second addFileSerials
+
+addGlobalSerials
+ :: Tr.Traversable f
+ => [S.S4 (a, f b) x y z]
+ -> [S.S4 ((L.GlobalTransaction, a), f (L.GlobalPosting, b)) x y z]
+addGlobalSerials
+ = addGlobalTransaction
+ . addGlobalPosting
+
+addAllMetadata
+ :: Tr.Traversable f
+ => [(L.Filename, [S.S4 (a, f b) x y z])]
+ -> [S.S4 ((L.GlobalTransaction, (L.Filename, (L.FileTransaction, a))),
+ f (L.GlobalPosting, (L.FilePosting, b))) x y z]
+addAllMetadata
+ = addGlobalSerials
+ . concat
+ . map addFileData
+
+rewrapMetadata
+ :: Functor f
+ => ( (L.GlobalTransaction, (L.Filename, (L.FileTransaction, I.ParsedTopLine)))
+ , f (L.GlobalPosting, (L.FilePosting, (L.PostingCore, L.PostingLine))))
+ -> (L.TopLineData, f (L.PostingData))
+rewrapMetadata ((gt, (fn, (ft, ptl))), ctr) = (tld, fmap f ctr)
+ where
+ tld = L.TopLineData
+ tlc
+ (Just (L.TopLineFileMeta fn (I.ptlTopLineLine ptl)
+ (fmap snd $ I.ptlMemo ptl)
+ ft))
+ (Just gt)
+ tlc = L.TopLineCore (I.ptlDateTime ptl) (I.ptlNumber ptl)
+ (I.ptlFlag ptl) (I.ptlPayee ptl)
+ (fmap fst $ I.ptlMemo ptl)
+ f (gp, (fp, (pc, pl))) = L.PostingData
+ pc
+ (Just (L.PostingFileMeta pl fp))
+ (Just gp)
+
+parsedToWrapped
+ :: [(L.Filename, [I.ParsedItem])]
+ -> [I.LedgerItem]
+parsedToWrapped = map rewrap . addAllMetadata where
+ rewrap i = case i of
+ S.S4a x -> S.S4a (L.Transaction . rewrapMetadata $ x)
+ S.S4b x -> S.S4b x
+ S.S4c x -> S.S4c x
+ S.S4d x -> S.S4d x
+
diff --git a/lib/Penny/Copper/Interface.hs b/lib/Penny/Copper/Interface.hs
new file mode 100644
index 0000000..9994718
--- /dev/null
+++ b/lib/Penny/Copper/Interface.hs
@@ -0,0 +1,49 @@
+module Penny.Copper.Interface where
+
+import qualified Penny.Lincoln as L
+import qualified Data.Text as X
+import qualified Penny.Steel.Sums as S
+
+data ParsedTopLine = ParsedTopLine
+ { ptlDateTime :: L.DateTime
+ , ptlNumber :: Maybe L.Number
+ , ptlFlag :: Maybe L.Flag
+ , ptlPayee :: Maybe L.Payee
+ , ptlMemo :: Maybe (L.Memo, L.TopMemoLine)
+ , ptlTopLineLine :: L.TopLineLine
+ } deriving (Show)
+
+toTopLineCore :: ParsedTopLine -> L.TopLineCore
+toTopLineCore (ParsedTopLine dt nu fl pa me _)
+ = L.TopLineCore dt nu fl pa (fmap fst me)
+
+type ParsedTxn = (ParsedTopLine , L.Ents (L.PostingCore, L.PostingLine))
+
+data BlankLine = BlankLine
+ deriving (Eq, Show)
+
+newtype Comment = Comment { unComment :: X.Text }
+ deriving (Eq, Show)
+
+type ParsedItem =
+ S.S4 ParsedTxn L.PricePoint Comment BlankLine
+
+type LedgerItem =
+ S.S4 L.Transaction L.PricePoint Comment BlankLine
+
+type Parser
+ = String
+ -- ^ Filename of the file to be parsed
+ -> IO (L.Filename, [ParsedItem])
+
+-- | Changes a ledger item to remove metadata.
+stripMeta
+ :: LedgerItem
+ -> S.S4 (L.TopLineCore, L.Ents L.PostingCore)
+ L.PricePoint
+ Comment
+ BlankLine
+stripMeta = S.mapS4 f id id id where
+ f t = let (tl, es) = L.unTransaction t
+ in (L.tlCore tl, fmap L.pdCore es)
+
diff --git a/lib/Penny/Copper/Parsec.hs b/lib/Penny/Copper/Parsec.hs
new file mode 100644
index 0000000..492444a
--- /dev/null
+++ b/lib/Penny/Copper/Parsec.hs
@@ -0,0 +1,567 @@
+-- | Parsec parsers for the ledger file format.
+module Penny.Copper.Parsec where
+
+-- # Imports
+
+import qualified Penny.Copper.Interface as I
+import qualified Penny.Copper.Terminals as T
+import Text.Parsec.Text (Parser)
+import Text.Parsec (many, many1, satisfy, (<?>))
+import qualified Text.Parsec as P
+import qualified Text.Parsec.Pos as Pos
+import Control.Applicative.Permutation (runPerms, maybeAtom)
+import Control.Applicative ((<$>), (<$), (<*>), (*>), (<*),
+ (<|>), optional)
+import Control.Monad (replicateM, when)
+import qualified Control.Monad.Exception.Synchronous as Ex
+import Data.List.NonEmpty (NonEmpty((:|)))
+import qualified Penny.Lincoln as L
+import qualified Penny.Steel.Sums as S
+import Data.Maybe (fromMaybe)
+import Data.Text (Text, pack)
+import qualified Data.Text as X
+import qualified Data.Time as Time
+import qualified System.Exit as Exit
+import System.Environment (getProgName)
+import qualified System.IO as IO
+import qualified Data.Text.IO as TIO
+
+-- # Helpers
+
+nonEmpty :: Parser a -> Parser (NonEmpty a)
+nonEmpty p = (:|) <$> p <*> many p
+
+-- # Accounts
+
+lvl1SubAcct :: Parser L.SubAccount
+lvl1SubAcct =
+ (L.SubAccount . pack) <$> many1 (satisfy T.lvl1AcctChar)
+
+lvl1FirstSubAcct :: Parser L.SubAccount
+lvl1FirstSubAcct = lvl1SubAcct
+
+lvl1OtherSubAcct :: Parser L.SubAccount
+lvl1OtherSubAcct = satisfy T.colon *> lvl1SubAcct
+
+lvl1Acct :: Parser L.Account
+lvl1Acct = f <$> lvl1FirstSubAcct <*> many lvl1OtherSubAcct
+ where
+ f a as = L.Account (a:as)
+
+quotedLvl1Acct :: Parser L.Account
+quotedLvl1Acct =
+ satisfy T.openCurly *> lvl1Acct <* satisfy T.closeCurly
+
+lvl2FirstSubAcct :: Parser L.SubAccount
+lvl2FirstSubAcct =
+ (\c cs -> L.SubAccount (pack (c:cs)))
+ <$> satisfy T.letter
+ <*> many (satisfy T.lvl2AcctOtherChar)
+
+lvl2OtherSubAcct :: Parser L.SubAccount
+lvl2OtherSubAcct =
+ (L.SubAccount . pack)
+ <$ satisfy T.colon
+ <*> many1 (satisfy T.lvl2AcctOtherChar)
+
+lvl2Acct :: Parser L.Account
+lvl2Acct =
+ (\a as -> L.Account (a:as))
+ <$> lvl2FirstSubAcct
+ <*> many lvl2OtherSubAcct
+
+ledgerAcct :: Parser L.Account
+ledgerAcct = quotedLvl1Acct <|> lvl2Acct
+
+-- # Commodities
+
+lvl1Cmdty :: Parser L.Commodity
+lvl1Cmdty = (L.Commodity . pack) <$> many1 (satisfy T.lvl1CmdtyChar)
+
+quotedLvl1Cmdty :: Parser L.Commodity
+quotedLvl1Cmdty =
+ satisfy T.doubleQuote *> lvl1Cmdty <* satisfy (T.doubleQuote)
+
+lvl2Cmdty :: Parser L.Commodity
+lvl2Cmdty =
+ (\c cs -> L.Commodity (pack (c:cs)))
+ <$> satisfy T.lvl2CmdtyFirstChar
+ <*> many (satisfy T.lvl2CmdtyOtherChar)
+
+lvl3Cmdty :: Parser L.Commodity
+lvl3Cmdty = (L.Commodity . pack) <$> many1 (satisfy T.lvl3CmdtyChar)
+
+-- # Quantities
+
+digit :: Parser L.Digit
+digit = (P.choice . map f $ zip ['0'..'9'] [minBound..maxBound])
+ <?> "digit"
+ where
+ f (s, d) = d <$ P.char s
+
+digitList :: Parser L.DigitList
+digitList = L.DigitList <$> nonEmpty digit
+
+groupPart :: Parser a -> Parser (a, L.DigitList)
+groupPart p = (,) <$> p <*> digitList
+
+groupedDigits :: Parser a -> Parser (L.GroupedDigits a)
+groupedDigits p
+ = L.GroupedDigits <$> digitList <*> many (groupPart p)
+
+-- | Parses a sequence of grouped digits, followed by an optional
+-- radix point, followed by an optional additional sequence of grouped
+-- digits. Numbers such as .25 are not allowed; instead,
+-- the user must enter 0.25. Also not allowed is something like
+-- "25.". Intsead, if the user enters a radix, there must be a
+-- character after it.
+digitsRadDigits
+ :: Parser a
+ -- ^ Parses a single grouping character
+ -> Parser void
+ -- ^ Parses a radix point
+ -> Parser (L.GroupedDigits a, Maybe (L.GroupedDigits a))
+digitsRadDigits gc r = do
+ g1 <- groupedDigits gc
+ maybeRad <- optional r
+ case maybeRad of
+ Nothing -> return (g1, Nothing)
+ Just _ -> do
+ g2 <- groupedDigits gc
+ return (g1, Just g2)
+
+-- | Parses an unquoted QtyRep.
+unquotedQtyRep :: Parser L.QtyRep
+unquotedQtyRep = do
+ let gc = P.choice [ L.PGThinSpace <$ P.char '\x2009'
+ , L.PGComma <$ P.char ',' ]
+ r = P.char '.'
+ (g1, mayg2) <- digitsRadDigits gc r
+ case L.wholeOrFrac g1 mayg2 of
+ Nothing -> fail "failed to parse quantity"
+ Just ei -> return . L.wholeOrFracToQtyRep . Left $ ei
+
+-- | Parses an unquoted QtyRep that also has spaces. Use only when
+-- parsing command line items.
+unquotedQtyRepWithSpaces :: Parser L.QtyRep
+unquotedQtyRepWithSpaces = do
+ let gc = P.choice [ L.PGThinSpace <$ P.char '\x2009'
+ , L.PGComma <$ P.char ','
+ , L.PGSpace <$ P.char ' ' ]
+ r = P.char '.'
+ (g1, mayg2) <- digitsRadDigits gc r
+ case L.wholeOrFrac g1 mayg2 of
+ Nothing -> fail "failed to parse quantity"
+ Just ei -> return . L.wholeOrFracToQtyRep . Left $ ei
+
+-- | Parses a QtyRep that is quoted with square braces. This is a
+-- QtyRep that uses a comma as the radix point.
+quotedCommaQtyRep :: Parser L.QtyRep
+quotedCommaQtyRep = do
+ let gc = P.choice [ L.CGThinSpace <$ P.char '\x2009'
+ , L.CGSpace <$ P.char ' '
+ , L.CGPeriod <$ P.char '.' ]
+ r = P.char ','
+ _ <- P.char '['
+ (g1, mayg2) <- digitsRadDigits gc r
+ _ <- P.char ']'
+ case L.wholeOrFrac g1 mayg2 of
+ Nothing -> fail "failed to parse quantity"
+ Just ei -> return . L.wholeOrFracToQtyRep . Right $ ei
+
+-- | Parses a QtyRep that is quoted with curly braces. This is a
+-- QtyRep that uses a period as the radix point. Unlike an unquoted
+-- QtyRep this can include spaces.
+quotedPeriodQtyRep :: Parser L.QtyRep
+quotedPeriodQtyRep = do
+ let gc = P.choice [ L.PGThinSpace <$ P.char '\x2009'
+ , L.PGComma <$ P.char ','
+ , L.PGSpace <$ P.char ' '
+ ]
+ r = P.char '.'
+ _ <- P.char '{'
+ (g1, mayg2) <- digitsRadDigits gc r
+ _ <- P.char '}'
+ case L.wholeOrFrac g1 mayg2 of
+ Nothing -> fail "failed to parse quantity"
+ Just ei -> return . L.wholeOrFracToQtyRep . Left $ ei
+
+qtyRep :: Parser L.QtyRep
+qtyRep = unquotedQtyRep <|> quotedPeriodQtyRep <|> quotedCommaQtyRep
+ <?> "quantity"
+
+-- # Amounts
+
+spaceBetween :: Parser L.SpaceBetween
+spaceBetween = f <$> optional (many1 (satisfy T.white))
+ where
+ f = maybe L.NoSpaceBetween (const L.SpaceBetween)
+
+leftCmdtyLvl1Amt :: Parser (L.Amount L.QtyRep, L.Side, L.SpaceBetween)
+leftCmdtyLvl1Amt =
+ f <$> quotedLvl1Cmdty <*> spaceBetween <*> qtyRep
+ where
+ f c s q = (L.Amount q c , L.CommodityOnLeft, s)
+
+leftCmdtyLvl3Amt :: Parser (L.Amount L.QtyRep, L.Side, L.SpaceBetween)
+leftCmdtyLvl3Amt = f <$> lvl3Cmdty <*> spaceBetween <*> qtyRep
+ where
+ f c s q = (L.Amount q c, L.CommodityOnLeft, s)
+
+leftSideCmdtyAmt :: Parser (L.Amount L.QtyRep, L.Side, L.SpaceBetween)
+leftSideCmdtyAmt = leftCmdtyLvl1Amt <|> leftCmdtyLvl3Amt
+
+rightSideCmdty :: Parser L.Commodity
+rightSideCmdty = quotedLvl1Cmdty <|> lvl2Cmdty
+
+rightSideCmdtyAmt :: Parser (L.Amount L.QtyRep, L.Side, L.SpaceBetween)
+rightSideCmdtyAmt =
+ f <$> qtyRep <*> spaceBetween <*> rightSideCmdty
+ where
+ f q s c = (L.Amount q c, L.CommodityOnRight, s)
+
+
+amount :: Parser (L.Amount L.QtyRep, L.Side, L.SpaceBetween)
+amount = leftSideCmdtyAmt <|> rightSideCmdtyAmt
+
+-- # Comments
+
+comment :: Parser I.Comment
+comment =
+ (I.Comment . pack)
+ <$ satisfy T.hash
+ <*> many (satisfy T.nonNewline)
+ <* satisfy T.newline
+ <* many (satisfy T.white)
+
+-- # Dates and times
+
+year :: Parser Integer
+year = read <$> replicateM 4 P.digit
+
+month :: Parser Int
+month = read <$> replicateM 2 P.digit
+
+day :: Parser Int
+day = read <$> replicateM 2 P.digit
+
+date :: Parser Time.Day
+date = p >>= failOnErr
+ where
+ p = Time.fromGregorianValid
+ <$> year <* satisfy T.dateSep
+ <*> month <* satisfy T.dateSep
+ <*> day
+ failOnErr = maybe (fail "could not parse date") return
+
+hours :: Parser L.Hours
+hours = p >>= (maybe (fail "could not parse hours") return)
+ where
+ p = f <$> satisfy T.digit <*> satisfy T.digit
+ f d1 d2 = L.intToHours . read $ [d1,d2]
+
+
+minutes :: Parser L.Minutes
+minutes = p >>= maybe (fail "could not parse minutes") return
+ where
+ p = f <$ satisfy T.colon <*> satisfy T.digit <*> satisfy T.digit
+ f d1 d2 = L.intToMinutes . read $ [d1, d2]
+
+seconds :: Parser L.Seconds
+seconds = p >>= maybe (fail "could not parse seconds") return
+ where
+ p = f <$ satisfy T.colon <*> satisfy T.digit <*> satisfy T.digit
+ f d1 d2 = L.intToSeconds . read $ [d1, d2]
+
+time :: Parser (L.Hours, L.Minutes, Maybe L.Seconds)
+time = (,,) <$> hours <*> minutes <*> optional seconds
+
+tzSign :: Parser (Int -> Int)
+tzSign = (id <$ satisfy T.plus) <|> (negate <$ satisfy T.minus)
+
+tzNumber :: Parser Int
+tzNumber = read <$> replicateM 4 (satisfy T.digit)
+
+timeZone :: Parser L.TimeZoneOffset
+timeZone = p >>= maybe (fail "could not parse time zone") return
+ where
+ p = f <$> tzSign <*> tzNumber
+ f s = L.minsToOffset . s
+
+timeWithZone
+ :: Parser (L.Hours, L.Minutes,
+ Maybe L.Seconds, Maybe L.TimeZoneOffset)
+timeWithZone =
+ f <$> time <* many (satisfy T.white) <*> optional timeZone
+ where
+ f (h, m, s) tz = (h, m, s, tz)
+
+dateTime :: Parser L.DateTime
+dateTime =
+ f <$> date <* many (satisfy T.white) <*> optional timeWithZone
+ where
+ f d mayTwithZ = L.DateTime d h m s tz
+ where
+ ((h, m, s), tz) = case mayTwithZ of
+ Nothing -> (L.midnight, L.noOffset)
+ Just (hr, mn, mayS, mayTz) ->
+ let sec = fromMaybe L.zeroSeconds mayS
+ z = fromMaybe L.noOffset mayTz
+ in ((hr, mn, sec), z)
+
+-- # Debit and credit
+
+debit :: Parser L.DrCr
+debit = L.Debit <$ satisfy T.lessThan
+
+credit :: Parser L.DrCr
+credit = L.Credit <$ satisfy T.greaterThan
+
+drCr :: Parser L.DrCr
+drCr = debit <|> credit
+
+-- # Entries
+
+entry :: Parser (L.Entry L.QtyRep, L.Side, L.SpaceBetween)
+entry = f <$> drCr <* (many (satisfy T.white)) <*> amount
+ where
+ f dc (am, sd, sb) = (L.Entry dc am, sd, sb)
+
+-- # Flag
+
+flag :: Parser L.Flag
+flag = (L.Flag . pack) <$ satisfy T.openSquare
+ <*> many (satisfy T.flagChar) <* satisfy (T.closeSquare)
+
+-- # Memos
+
+-- ## Posting memo
+
+postingMemoLine :: Parser Text
+postingMemoLine =
+ pack
+ <$ satisfy T.apostrophe
+ <*> many (satisfy T.nonNewline)
+ <* satisfy T.newline <* many (satisfy T.white)
+
+postingMemo :: Parser L.Memo
+postingMemo = L.Memo <$> many1 postingMemoLine
+
+-- ## Transaction memo
+
+transactionMemoLine :: Parser Text
+transactionMemoLine =
+ pack
+ <$ satisfy T.semicolon <*> many (satisfy T.nonNewline)
+ <* satisfy T.newline <* skipWhite
+
+transactionMemo :: Parser (L.TopMemoLine, L.Memo)
+transactionMemo = f <$> lineNum <*> many1 transactionMemoLine
+ where
+ f tml ls = (L.TopMemoLine tml
+ , L.Memo ls)
+
+
+-- # Number
+
+number :: Parser L.Number
+number =
+ L.Number . pack <$ satisfy T.openParen
+ <*> many (satisfy T.numberChar) <* satisfy T.closeParen
+
+-- # Payees
+
+lvl1Payee :: Parser L.Payee
+lvl1Payee = L.Payee . pack <$> many (satisfy T.quotedPayeeChar)
+
+quotedLvl1Payee :: Parser L.Payee
+quotedLvl1Payee = satisfy T.tilde *> lvl1Payee <* satisfy T.tilde
+
+lvl2Payee :: Parser L.Payee
+lvl2Payee = (\c cs -> L.Payee (pack (c:cs))) <$> satisfy T.letter
+ <*> many (satisfy T.nonNewline)
+
+-- # Prices
+
+fromCmdty :: Parser L.From
+fromCmdty = L.From <$> (quotedLvl1Cmdty <|> lvl2Cmdty)
+
+lineNum :: Parser Int
+lineNum = Pos.sourceLine <$> P.getPosition
+
+price :: Parser L.PricePoint
+price = p >>= maybe (fail msg) return
+ where
+ f li dt fr (L.Amount qt to, sd, sb) =
+ let cpu = L.CountPerUnit qt
+ in case L.newPrice fr (L.To to) cpu of
+ Nothing -> Nothing
+ Just pr -> Just $ L.PricePoint dt pr
+ (Just sd) (Just sb) (Just $ L.PriceLine li)
+ p = f <$> lineNum <* satisfy T.atSign <* skipWhite
+ <*> dateTime <* skipWhite
+ <*> fromCmdty <* skipWhite
+ <*> amount <* satisfy T.newline <* skipWhite
+ msg = "could not parse price, make sure the from and to commodities "
+ ++ "are different"
+
+-- # Tags
+
+tag :: Parser L.Tag
+tag = L.Tag . pack <$ satisfy T.asterisk <*> many (satisfy T.tagChar)
+ <* many (satisfy T.white)
+
+tags :: Parser L.Tags
+tags = (\t ts -> L.Tags (t:ts)) <$> tag <*> many tag
+
+-- # TopLine
+
+topLinePayee :: Parser L.Payee
+topLinePayee = quotedLvl1Payee <|> lvl2Payee
+
+topLineFlagNum :: Parser (Maybe L.Flag, Maybe L.Number)
+topLineFlagNum = p1 <|> p2
+ where
+ p1 = ( (,) <$> optional flag
+ <* many (satisfy T.white) <*> optional number)
+ p2 = ( flip (,)
+ <$> optional number
+ <* many (satisfy T.white) <*> optional flag)
+
+skipWhite :: Parser ()
+skipWhite = () <$ many (satisfy T.white)
+
+topLine :: Parser I.ParsedTopLine
+topLine =
+ f <$> optional transactionMemo
+ <*> lineNum
+ <*> dateTime
+ <* skipWhite
+ <*> topLineFlagNum
+ <* skipWhite
+ <*> optional topLinePayee
+ <* satisfy T.newline
+ <* skipWhite
+ where
+ f mayMe lin dt (mayFl, mayNum) mayPy =
+ I.ParsedTopLine dt mayNum mayFl mayPy me (L.TopLineLine lin)
+ where
+ me = fmap (\(a, b) -> (b, a)) mayMe
+
+-- # Postings
+
+flagNumPayee :: Parser (Maybe L.Flag, Maybe L.Number, Maybe L.Payee)
+flagNumPayee = runPerms
+ ( (,,) <$> maybeAtom (flag <* skipWhite)
+ <*> maybeAtom (number <* skipWhite)
+ <*> maybeAtom (quotedLvl1Payee <* skipWhite) )
+
+postingAcct :: Parser L.Account
+postingAcct = quotedLvl1Acct <|> lvl2Acct
+
+posting :: Parser (L.PostingCore, L.PostingLine, Maybe (L.Entry L.QtyRep))
+posting = f <$> lineNum <* skipWhite
+ <*> optional flagNumPayee <* skipWhite
+ <*> postingAcct <* skipWhite
+ <*> optional tags <* skipWhite
+ <*> optional entry <* skipWhite
+ <* satisfy T.newline <* skipWhite
+ <*> optional postingMemo <* skipWhite
+ where
+ f li mayFnp ac ta mayEn me =
+ (L.PostingCore pa nu fl ac tgs me sd sb, pl, en)
+ where
+ tgs = fromMaybe (L.Tags []) ta
+ pl = L.PostingLine li
+ (fl, nu, pa) = fromMaybe (Nothing, Nothing, Nothing) mayFnp
+ (en, sd, sb) = maybe (Nothing, Nothing, Nothing)
+ (\(a, b, c) -> (Just a, Just b, Just c)) mayEn
+
+-- # Transaction
+
+transaction :: Parser I.ParsedTxn
+transaction = do
+ ptl <- topLine
+ let getEntPair (core, lin, mayEn) = (fmap Left mayEn, (core, lin))
+ ts <- fmap (map getEntPair) $ many posting
+ ents <- maybe (fail "unbalanced transaction") return $ L.ents ts
+ return (ptl, ents)
+
+
+-- # Blank line
+
+blankLine :: Parser ()
+blankLine = () <$ satisfy T.newline <* skipWhite
+
+-- # Item
+
+item :: Parser I.ParsedItem
+item
+ = fmap S.S4a transaction
+ <|> fmap S.S4b price
+ <|> fmap S.S4c comment
+ <|> (S.S4d I.BlankLine) <$ blankLine
+
+
+-- # Parsing
+
+parse
+ :: Text
+ -- ^ Contents of file to be parsed
+
+ -> Ex.Exceptional String [I.ParsedItem]
+ -- ^ Returns items if successfully parsed; otherwise, returns an
+ -- error message.
+
+parse s =
+ let parser = P.spaces *> P.many item <* P.spaces <* P.eof
+ in Ex.mapException show . Ex.fromEither
+ $ P.parse parser "" s
+
+
+getStdin :: IO Text
+getStdin = do
+ pn <- getProgName
+ isTerm <- IO.hIsTerminalDevice IO.stdin
+ when isTerm
+ (IO.hPutStrLn IO.stderr $
+ pn ++ ": warning: reading from standard input, which"
+ ++ " is a terminal.")
+ TIO.hGetContents IO.stdin
+
+
+getFileContentsStdin :: String -> IO (L.Filename, Text)
+getFileContentsStdin s = do
+ txt <- if s == "-"
+ then getStdin
+ else TIO.readFile s
+ let fn = L.Filename . X.pack $ if s == "-" then "<stdin>" else s
+ return (fn, txt)
+
+
+parseStdinOnly :: IO (L.Filename, [I.ParsedItem])
+parseStdinOnly = do
+ txt <- getStdin
+ case parse txt of
+ Ex.Exception err -> handleParseError "standard input" err
+ Ex.Success g -> return (L.Filename . X.pack $ "<stdin>", g)
+
+parseFromFilename :: String -> IO (L.Filename, [I.ParsedItem])
+parseFromFilename s = do
+ (fn, txt) <- getFileContentsStdin s
+ case parse txt of
+ Ex.Exception err ->
+ handleParseError (X.unpack . L.unFilename $ fn) err
+ Ex.Success g -> return (fn, g)
+
+handleParseError
+ :: String
+ -- ^ Filename
+ -> String
+ -> IO a
+handleParseError fn e = do
+ pn <- getProgName
+ IO.hPutStrLn IO.stderr $ pn
+ ++ ": error: could not parse " ++ fn ++ ":"
+ IO.hPutStrLn IO.stderr e
+ Exit.exitFailure
diff --git a/lib/Penny/Copper/Render.hs b/lib/Penny/Copper/Render.hs
new file mode 100644
index 0000000..728f547
--- /dev/null
+++ b/lib/Penny/Copper/Render.hs
@@ -0,0 +1,512 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Renders Penny data in a format that can be parsed by
+-- "Penny.Copper.Parsec". These functions render text that is
+-- compliant with the EBNF grammar which is at
+-- @doc\/ledger-grammar.org@.
+module Penny.Copper.Render where
+
+import Control.Monad (guard)
+import Control.Applicative ((<$>), (<|>), (<*>), pure)
+import Data.List (intersperse)
+import Data.Monoid ((<>))
+import qualified Data.Text as X
+import Data.Text (Text, cons, snoc)
+import qualified Penny.Copper.Terminals as T
+import qualified Data.Time as Time
+import qualified Penny.Copper.Interface as I
+import qualified Penny.Lincoln as L
+import qualified Penny.Steel.Sums as S
+
+-- * Helpers
+
+-- | Merges a list of words into one Text; however, if any given Text
+-- is empty, that Text is first dropped from the list.
+txtWords :: [X.Text] -> X.Text
+txtWords xs = case filter (not . X.null) xs of
+ [] -> X.empty
+ rs -> X.unwords rs
+
+-- | Takes a field that may or may not be present and a function that
+-- renders it. If the field is not present at all, returns an empty
+-- Text. Otherwise will succeed or fail depending upon whether the
+-- rendering function succeeds or fails.
+renMaybe :: Maybe a -> (a -> Maybe X.Text) -> Maybe X.Text
+renMaybe mx f = case mx of
+ Nothing -> Just X.empty
+ Just a -> f a
+
+
+-- * Accounts
+
+-- | Is True if a sub account can be rendered at Level 1;
+-- False otherwise.
+isSubAcctLvl1 :: L.SubAccount -> Bool
+isSubAcctLvl1 (L.SubAccount x) =
+ X.all T.lvl1AcctChar x && not (X.null x)
+
+isAcctLvl1 :: L.Account -> Bool
+isAcctLvl1 (L.Account ls) =
+ (not . null $ ls)
+ && (all isSubAcctLvl1 ls)
+
+quotedLvl1Acct :: L.Account -> Maybe Text
+quotedLvl1Acct a@(L.Account ls) = do
+ guard (isAcctLvl1 a)
+ let txt = X.concat . intersperse (X.singleton ':')
+ . map L.unSubAccount $ ls
+ return $ '{' `X.cons` txt `X.snoc` '}'
+
+isFirstSubAcctLvl2 :: L.SubAccount -> Bool
+isFirstSubAcctLvl2 (L.SubAccount x) = case X.uncons x of
+ Nothing -> False
+ Just (c, r) -> T.letter c && (X.all T.lvl2AcctOtherChar r)
+
+isOtherSubAcctLvl2 :: L.SubAccount -> Bool
+isOtherSubAcctLvl2 (L.SubAccount x) =
+ (not . X.null $ x)
+ && (X.all T.lvl2AcctOtherChar x)
+
+isAcctLvl2 :: L.Account -> Bool
+isAcctLvl2 (L.Account ls) = case ls of
+ [] -> False
+ x:xs -> isFirstSubAcctLvl2 x && all isOtherSubAcctLvl2 xs
+
+lvl2Acct :: L.Account -> Maybe Text
+lvl2Acct a@(L.Account ls) = do
+ guard $ isAcctLvl2 a
+ return . X.concat . intersperse (X.singleton ':')
+ . map L.unSubAccount $ ls
+
+-- | Shows an account, with the minimum level of quoting
+-- possible. Fails with an error if any one of the characters in the
+-- account name does not satisfy the 'lvl1Char' predicate. Otherwise
+-- returns a rendered account, quoted if necessary.
+ledgerAcct :: L.Account -> Maybe Text
+ledgerAcct a = lvl2Acct a <|> quotedLvl1Acct a
+
+-- * Commodities
+
+-- | Render a quoted Level 1 commodity. Fails if any character does
+-- not satisfy lvl1Char.
+quotedLvl1Cmdty :: L.Commodity -> Maybe Text
+quotedLvl1Cmdty (L.Commodity c) =
+ if X.all T.lvl1CmdtyChar c
+ then Just $ '"' `cons` c `snoc` '"'
+ else Nothing
+
+
+-- | Render a Level 2 commodity. Fails if the first character is not a
+-- letter or a symbol, or if any other character is a space.
+lvl2Cmdty :: L.Commodity -> Maybe Text
+lvl2Cmdty (L.Commodity c) = do
+ (f, rs) <- X.uncons c
+ guard $ T.lvl2CmdtyFirstChar f
+ guard . X.all T.lvl2CmdtyOtherChar $ rs
+ return c
+
+
+-- | Render a Level 3 commodity. Fails if any character is not a
+-- letter or a symbol.
+lvl3Cmdty :: L.Commodity -> Maybe Text
+lvl3Cmdty (L.Commodity c) =
+ if (not . X.null $ c) && (X.all T.lvl3CmdtyChar c)
+ then return c
+ else Nothing
+
+
+-- * Quantities
+
+-- | Gets the characters necessary to quote a qtyRep.
+quoteQtyRep :: L.QtyRep -> (Text, Text)
+quoteQtyRep q = case q of
+ L.QNoGrouping _ r -> case r of
+ L.Period -> ("", "")
+ L.Comma -> ("[", "]")
+ L.QGrouped ei -> case ei of
+ Left wf -> if hasSpace wf then ("{", "}") else ("", "")
+ Right _ -> ("[", "]")
+
+qtyRep :: L.QtyRep -> Text
+qtyRep q = b <> L.showQtyRep q <> e
+ where
+ (b, e) = quoteQtyRep q
+
+hasSpace :: L.WholeOrFrac (L.GroupedDigits L.PeriodGrp) -> Bool
+hasSpace (L.WholeOrFrac ei) = case ei of
+ Left w -> grpHasSpace . L.unWholeOnly $ w
+ Right wf -> grpHasSpace (L.whole wf) || grpHasSpace (L.frac wf)
+ where
+ grpHasSpace grp = L.PGSpace `elem` (map fst . L.dsNextParts $ grp)
+
+
+-- * Amounts
+
+-- | Render an Amount. The Format is required so that the commodity
+-- can be displayed in the right place.
+amount
+ :: Maybe (L.Amount L.Qty -> S.S3 L.Radix L.PeriodGrp L.CommaGrp)
+ -- ^ If Just, render entries that are NOT inferred and that do not
+ -- have a QtyRep. If Nothing, fail if an entry is NOT inferred and
+ -- does not have a QtyRep. (Inferred entries are always rendered
+ -- without an entry.)
+ -> Maybe L.Side
+ -> Maybe L.SpaceBetween
+ -> Either (L.Amount L.QtyRep) (L.Amount L.Qty)
+ -> Maybe X.Text
+amount mayFmt maySd maySb ei = do
+ (q, c) <- case ei of
+ Left a -> return (qtyRep . L.qty $ a, L.commodity a)
+ Right a -> case mayFmt of
+ Nothing -> Nothing
+ Just f -> return ( qtyRep . L.qtyToRep (f a) . L.qty $ a,
+ L.commodity a)
+ sd <- maySd
+ sb <- maySb
+ let ws = case sb of
+ L.SpaceBetween -> X.singleton ' '
+ L.NoSpaceBetween -> X.empty
+ (l, r) <- case sd of
+ L.CommodityOnLeft -> do
+ cx <- lvl3Cmdty c <|> quotedLvl1Cmdty c
+ return (cx, q)
+ L.CommodityOnRight -> do
+ cx <- lvl2Cmdty c <|> quotedLvl1Cmdty c
+ return (q, cx)
+ return $ X.concat [l, ws, r]
+
+-- * Comments
+
+comment :: I.Comment -> Maybe X.Text
+comment (I.Comment x) =
+ if (not . X.all T.nonNewline $ x)
+ then Nothing
+ else Just $ '#' `cons` x `snoc` '\n'
+
+-- * DateTime
+
+-- | Render a DateTime. The day is always printed. If the time zone
+-- offset is not zero, then the time and time zone offset are both
+-- printed. If the time zone offset is zero, then the hours and
+-- minutes are printed, but only if the time is not midnight. If the
+-- seconds are not zero, they are also printed.
+
+dateTime :: L.DateTime -> X.Text
+dateTime (L.DateTime d h m s z) = X.append xd xr
+ where
+ (iYr, iMo, iDy) = Time.toGregorian d
+ xr = hoursMinsSecsZone h m s z
+ dash = X.singleton '-'
+ xd = X.concat [ showX iYr, dash, pad2 . showX $ iMo, dash,
+ pad2 . showX $ iDy ]
+
+pad2 :: X.Text -> X.Text
+pad2 = X.justifyRight 2 '0'
+
+pad4 :: X.Text -> X.Text
+pad4 = X.justifyRight 4 '0'
+
+showX :: Show a => a -> X.Text
+showX = X.pack . show
+
+hoursMinsSecsZone
+ :: L.Hours -> L.Minutes -> L.Seconds -> L.TimeZoneOffset -> X.Text
+hoursMinsSecsZone h m s z =
+ if z == L.noOffset && (h, m, s) == L.midnight
+ then X.empty
+ else let xhms = X.concat [xh, colon, xm, xs]
+ xh = pad2 . showX . L.unHours $ h
+ xm = pad2 . showX . L.unMinutes $ m
+ xs = let secs = L.unSeconds s
+ in if secs == 0
+ then X.empty
+ else ':' `X.cons` (pad2 . showX $ secs)
+ off = L.offsetToMins z
+ sign = X.singleton $ if off < 0 then '-' else '+'
+ padded = pad4 . showX . abs $ off
+ xz = if off == 0
+ then X.empty
+ else ' ' `X.cons` sign `X.append` padded
+ colon = X.singleton ':'
+ in ' ' `X.cons` xhms `X.append` xz
+
+-- * Entries
+
+entry
+ :: Maybe (L.Amount L.Qty -> S.S3 L.Radix L.PeriodGrp L.CommaGrp)
+ -- ^ If Just, render entries that are NOT inferred and that do not
+ -- have a QtyRep. If Nothing, fail if an entry is NOT inferred and
+ -- does not have a QtyRep. (Inferred entries are always rendered
+ -- without an entry.)
+ -> Maybe L.Side
+ -> Maybe L.SpaceBetween
+ -> Either (L.Entry L.QtyRep) (L.Entry L.Qty)
+ -> Maybe X.Text
+entry mayFmt sd sb ei = do
+ amt <- amount mayFmt sd sb
+ (either (Left . L.amount) (Right . L.amount) ei)
+ let dc = either L.drCr L.drCr ei
+ dcTxt = X.pack $ case dc of
+ L.Debit -> "<"
+ L.Credit -> ">"
+ return $ X.append (X.snoc dcTxt ' ') amt
+
+-- * Flags
+
+flag :: L.Flag -> Maybe X.Text
+flag (L.Flag fl) =
+ if X.all T.flagChar fl
+ then Just $ '[' `cons` fl `snoc` ']'
+ else Nothing
+
+-- * Memos
+
+-- | Renders a postingMemoLine, optionally with trailing
+-- whitespace. The trailing whitespace allows the next line to be
+-- indented properly if is also a postingMemoLine. This is handled
+-- using trailing whitespace rather than leading whitespace because
+-- leading whitespace is inconsistent with the grammar.
+postingMemoLine
+ :: Int
+ -- ^ Pad the end of the output with this many spaces
+ -> X.Text
+ -> Maybe X.Text
+postingMemoLine p x =
+ if X.all T.nonNewline x
+ then let trailing = X.replicate p (X.singleton ' ')
+ ls = [X.singleton '\'', x, X.singleton '\n', trailing]
+ in Just $ X.concat ls
+ else Nothing
+
+-- | Renders a postingMemo. Fails if the postingMemo is empty, as the
+-- grammar requires that they have at least one line.
+--
+-- If the boolean is True, inserts padding after the last
+-- postingMemoLine so that the next line is indented by four
+-- columns. Use this if the posting memo is followed by another
+-- posting. If the last boolean if False, there is no indenting after
+-- the last postingMemoLine.
+postingMemo :: Bool -> L.Memo -> Maybe X.Text
+postingMemo iLast (L.Memo ls) =
+ if null ls
+ then Nothing
+ else let bs = replicate (length ls - 1) 8 ++ [if iLast then 4 else 0]
+ in fmap X.concat . sequence $ zipWith postingMemoLine bs ls
+
+
+transactionMemoLine :: X.Text -> Maybe X.Text
+transactionMemoLine x =
+ if X.all T.nonNewline x
+ then Just $ ';' `cons` x `snoc` '\n'
+ else Nothing
+
+transactionMemo :: L.Memo -> Maybe X.Text
+transactionMemo (L.Memo ls) =
+ if null ls
+ then Nothing
+ else fmap X.concat . mapM transactionMemoLine $ ls
+
+-- * Numbers
+
+number :: L.Number -> Maybe Text
+number (L.Number t) =
+ if X.all T.numberChar t
+ then Just $ '(' `cons` t `snoc` ')'
+ else Nothing
+
+-- * Payees
+
+quotedLvl1Payee :: L.Payee -> Maybe Text
+quotedLvl1Payee (L.Payee p) = do
+ guard (X.all T.quotedPayeeChar p)
+ return $ '~' `X.cons` p `X.snoc` '~'
+
+lvl2Payee :: L.Payee -> Maybe Text
+lvl2Payee (L.Payee p) = do
+ (c1, cs) <- X.uncons p
+ guard (T.letter c1)
+ guard (X.all T.nonNewline cs)
+ return p
+
+payee :: L.Payee -> Maybe Text
+payee p = lvl2Payee p <|> quotedLvl1Payee p
+
+-- * Prices
+
+price
+ :: L.PricePoint
+ -> Maybe X.Text
+price pp = let
+ dateTxt = dateTime (L.dateTime pp)
+ (L.From from) = L.from . L.price $ pp
+ (L.To to) = L.to . L.price $ pp
+ (L.CountPerUnit q) = L.countPerUnit . L.price $ pp
+ mayFromTxt = lvl3Cmdty from <|> quotedLvl1Cmdty from
+ in do
+ amtTxt <- amount Nothing (L.ppSide pp) (L.ppSpaceBetween pp)
+ (Left (L.Amount q to))
+ fromTxt <- mayFromTxt
+ return $
+ (X.intercalate (X.singleton ' ')
+ [X.singleton '@', dateTxt, fromTxt, amtTxt])
+ `snoc` '\n'
+
+-- * Tags
+
+tag :: L.Tag -> Maybe X.Text
+tag (L.Tag t) =
+ if X.all T.tagChar t
+ then Just $ X.cons '*' t
+ else Nothing
+
+tags :: L.Tags -> Maybe X.Text
+tags (L.Tags ts) =
+ X.intercalate (X.singleton ' ')
+ <$> mapM tag ts
+
+-- * TopLine
+
+-- | Renders the TopLine. Emits trailing whitespace after the newline
+-- so that the first posting is properly indented.
+topLine :: L.TopLineCore -> Maybe X.Text
+topLine tl =
+ f
+ <$> pure (dateTime (L.tDateTime tl))
+ <*> renMaybe (L.tMemo tl) transactionMemo
+ <*> renMaybe (L.tFlag tl) flag
+ <*> renMaybe (L.tNumber tl) number
+ <*> renMaybe (L.tPayee tl) payee
+ where
+ f dtX meX flX nuX paX =
+ X.concat [ meX, txtWords [dtX, flX, nuX, paX],
+ X.singleton '\n',
+ X.replicate 4 (X.singleton ' ') ]
+
+-- * Posting
+
+-- | Renders a Posting. Fails if any of the components
+-- fail to render. In addition, if the unverified Posting has an
+-- Entry, a Format must be provided, otherwise render fails.
+--
+-- The columns look like this. Column numbers begin with 0 (like they
+-- do in Emacs) rather than with column 1 (like they do in
+-- Vim). (Really Emacs is the strange one; most CLI utilities seem to
+-- start with column 1 too...)
+--
+-- > ID COLUMN WIDTH WHAT
+-- > ---------------------------------------------------
+-- > A 0 4 Blank spaces for indentation
+-- > B 4 50 Flag, Number, Payee, Account, Tags
+-- > C 54 2 Blank spaces for padding
+-- > D 56 NA Entry
+--
+-- Omit the padding after column B if there is no entry; also omit
+-- columns C and D entirely if there is no Entry. (It is annoying to
+-- have extraneous blank space in a file).
+--
+-- This table is a bit of a lie, because the blank spaces for
+-- indentation are emitted either by the posting previous to this one
+-- (either after the posting itself or after its postingMemo) or by
+-- the TopLine.
+--
+-- Also emits an additional eight spaces after the trailing newline if
+-- the posting has a memo. That way the memo will be indented
+-- properly. (There are trailing spaces here, as opposed to leading
+-- spaces in the posting memo, because the latter would be
+-- inconsistent with the grammar.)
+--
+-- Emits an extra four spaces after the first line if the first
+-- paramter is True. However, this is overriden if there is a memo, in
+-- which case eight spaces will be emitted. (This allows the next
+-- posting to be indented properly.)
+posting
+ :: Maybe (L.Amount L.Qty -> S.S3 L.Radix L.PeriodGrp L.CommaGrp)
+ -- ^ If Just, render entries that are NOT inferred and that do not
+ -- have a QtyRep. If Nothing, fail if an entry is NOT inferred and
+ -- does not have a QtyRep. (Inferred entries are always rendered
+ -- without an entry.)
+ -> Bool
+ -- ^ If True, emit four spaces after the trailing newline.
+ -> L.Ent L.PostingCore
+ -> Maybe X.Text
+posting maySpec pad ent = do
+ let p = L.meta ent
+ fl <- renMaybe (L.pFlag p) flag
+ nu <- renMaybe (L.pNumber p) number
+ pa <- renMaybe (L.pPayee p) quotedLvl1Payee
+ ac <- ledgerAcct (L.pAccount p)
+ ta <- tags (L.pTags p)
+ me <- renMaybe (L.pMemo p) (postingMemo pad)
+ let mayEn = if L.inferred ent then Nothing else Just $ L.entry ent
+ en <- renMaybe mayEn (entry maySpec (L.pSide p) (L.pSpaceBetween p))
+ return $ formatter pad fl nu pa ac ta en me
+
+formatter
+ :: Bool -- ^ If True, emit four trailing spaces if no memo or
+ -- eight trailing spaces if there is a memo.
+ -> X.Text -- ^ Flag
+ -> X.Text -- ^ Number
+ -> X.Text -- ^ Payee
+ -> X.Text -- ^ Account
+ -> X.Text -- ^ Tags
+ -> X.Text -- ^ Entry
+ -> X.Text -- ^ Memo
+ -> X.Text
+formatter pad fl nu pa ac ta en me = let
+ colBnoPad = txtWords [fl, nu, pa, ac, ta]
+ colD = en
+ colB = if X.null en
+ then colBnoPad
+ else X.justifyLeft 50 ' ' colBnoPad
+ colC = if X.null en
+ then X.empty
+ else X.pack (replicate 2 ' ')
+ rtn = '\n' `X.cons` trailingWhite
+ trailingWhite = case (X.null me, pad) of
+ (True, False) -> X.empty
+ (True, True) -> X.replicate 4 (X.singleton ' ')
+ (False, _) -> X.replicate 8 (X.singleton ' ')
+ in X.concat [colB, colC, colD, rtn, me]
+
+
+-- * Transaction
+
+transaction
+ :: Maybe (L.Amount L.Qty -> S.S3 L.Radix L.PeriodGrp L.CommaGrp)
+ -- ^ If Just, render entries that are NOT inferred and that do not
+ -- have a QtyRep. If Nothing, fail if an entry is NOT inferred and
+ -- does not have a QtyRep. (Inferred entries are always rendered
+ -- without an entry.)
+ -> (L.TopLineCore, L.Ents L.PostingCore)
+ -> Maybe X.Text
+transaction mayFmt txn = do
+ tlX <- topLine . fst $ txn
+ let (p1, p2, ps) = L.tupleEnts . snd $ txn
+ p1X <- posting mayFmt True p1
+ p2X <- posting mayFmt (not . null $ ps) p2
+ psX <- if null ps
+ then return X.empty
+ else let bs = replicate (length ps - 1) True ++ [False]
+ in fmap X.concat . sequence
+ $ zipWith (posting mayFmt) bs ps
+ return $ X.concat [tlX, p1X, p2X, psX]
+
+-- * Item
+
+item
+ :: Maybe (L.Amount L.Qty -> S.S3 L.Radix L.PeriodGrp L.CommaGrp)
+ -- ^ If Just, render entries that are NOT inferred and that do not
+ -- have a QtyRep. If Nothing, fail if an entry is NOT inferred and
+ -- does not have a QtyRep. (Inferred entries are always rendered
+ -- without an entry.)
+ -> S.S4 (L.TopLineCore, L.Ents L.PostingCore)
+ L.PricePoint
+ I.Comment
+ I.BlankLine
+ -> Maybe X.Text
+item mayFmt =
+ S.caseS4 (transaction mayFmt)
+ price
+ comment
+ (const (Just (X.pack "\n")))
+
diff --git a/lib/Penny/Copper/Terminals.hs b/lib/Penny/Copper/Terminals.hs
new file mode 100644
index 0000000..63ed076
--- /dev/null
+++ b/lib/Penny/Copper/Terminals.hs
@@ -0,0 +1,145 @@
+module Penny.Copper.Terminals where
+
+invalid :: Char -> Bool
+invalid c = c >= '\xD800' && c <= '\xDFFF'
+
+unicode :: Char -> Bool
+unicode = not . invalid
+
+newline :: Char -> Bool
+newline = (== '\x0A')
+
+space :: Char -> Bool
+space = (== '\x20')
+
+tab :: Char -> Bool
+tab = (== '\x09')
+
+white :: Char -> Bool
+white c = space c || tab c
+
+nonNewline :: Char -> Bool
+nonNewline c = unicode c && (not . newline $ c)
+
+nonNewlineNonSpace :: Char -> Bool
+nonNewlineNonSpace c = nonNewline c && (not . white $ c)
+
+upperCaseAscii :: Char -> Bool
+upperCaseAscii c = c >= 'A' && c <= 'Z'
+
+lowerCaseAscii :: Char -> Bool
+lowerCaseAscii c = c >= 'a' && c <= 'z'
+
+digit :: Char -> Bool
+digit c = c >= '0' && c <= '9'
+
+nonAscii :: Char -> Bool
+nonAscii c = nonNewline c && c > '\x7F'
+
+letter :: Char -> Bool
+letter c = upperCaseAscii c || lowerCaseAscii c || nonAscii c
+
+dollar :: Char -> Bool
+dollar = (== '$')
+
+colon :: Char -> Bool
+colon = (== ':')
+
+openCurly :: Char -> Bool
+openCurly = (== '{')
+
+closeCurly :: Char -> Bool
+closeCurly = (== '}')
+
+openSquare :: Char -> Bool
+openSquare = (== '[')
+
+closeSquare :: Char -> Bool
+closeSquare = (== ']')
+
+doubleQuote :: Char -> Bool
+doubleQuote = (== '"')
+
+period :: Char -> Bool
+period = (== '.')
+
+hash :: Char -> Bool
+hash = (== '#')
+
+thinSpace :: Char -> Bool
+thinSpace = (== '\x2009')
+
+dateSep :: Char -> Bool
+dateSep c = c == '/' || c == '-'
+
+plus :: Char -> Bool
+plus = (== '+')
+
+minus :: Char -> Bool
+minus = (== '-')
+
+lessThan :: Char -> Bool
+lessThan = (== '<')
+
+greaterThan :: Char -> Bool
+greaterThan = (== '>')
+
+openParen :: Char -> Bool
+openParen = (== '(')
+
+closeParen :: Char -> Bool
+closeParen = (== ')')
+
+semicolon :: Char -> Bool
+semicolon = (== ';')
+
+apostrophe :: Char -> Bool
+apostrophe = (== '\x27')
+
+tilde :: Char -> Bool
+tilde = (== '~')
+
+underscore :: Char -> Bool
+underscore = (== '_')
+
+asterisk :: Char -> Bool
+asterisk = (== '*')
+
+lvl1AcctChar :: Char -> Bool
+lvl1AcctChar c = nonNewline c && (not . closeCurly $ c)
+ && (not . colon $ c)
+
+lvl2AcctOtherChar :: Char -> Bool
+lvl2AcctOtherChar c =
+ nonNewline c && (not . white $ c) && (not . colon $ c)
+ && (not . asterisk $ c) && (not . greaterThan $ c)
+ && (not . lessThan $ c)
+
+lvl1CmdtyChar :: Char -> Bool
+lvl1CmdtyChar c =
+ nonNewline c && (not . doubleQuote $ c)
+
+lvl2CmdtyFirstChar :: Char -> Bool
+lvl2CmdtyFirstChar c = letter c || dollar c
+
+lvl2CmdtyOtherChar :: Char -> Bool
+lvl2CmdtyOtherChar c = nonNewline c && (not . white $ c)
+
+lvl3CmdtyChar :: Char -> Bool
+lvl3CmdtyChar c = letter c || dollar c
+
+flagChar :: Char -> Bool
+flagChar c = nonNewline c && (not . closeSquare $ c)
+
+numberChar :: Char -> Bool
+numberChar c = nonNewline c && (not . closeParen $ c)
+
+quotedPayeeChar :: Char -> Bool
+quotedPayeeChar c = nonNewline c && (not . tilde $ c)
+
+tagChar :: Char -> Bool
+tagChar c = nonNewlineNonSpace c && (not . asterisk $ c)
+ && (not . greaterThan $ c) && (not . lessThan $ c)
+
+atSign :: Char -> Bool
+atSign = (== '@')
diff --git a/lib/Penny/Liberty.hs b/lib/Penny/Liberty.hs
new file mode 100644
index 0000000..6846cde
--- /dev/null
+++ b/lib/Penny/Liberty.hs
@@ -0,0 +1,776 @@
+{-# LANGUAGE OverloadedStrings, CPP #-}
+
+-- | Liberty - Penny command line parsing utilities
+--
+-- Both Cabin and Zinc share various functions that aid in parsing
+-- command lines. For instance both the Postings report and the Zinc
+-- postings filter use common command-line options. However, Zinc
+-- already depends on Cabin. To avoid a cyclic dependency whereby
+-- Cabin would also depend on Zinc, functions formerly in Zinc that
+-- Cabin will also find useful are relocated here, to Liberty.
+
+module Penny.Liberty (
+ MatcherFactory,
+ FilteredNum(FilteredNum, unFilteredNum),
+ SortedNum(SortedNum, unSortedNum),
+ LibertyMeta(filteredNum, sortedNum),
+ xactionsToFiltered,
+ ListLength(ListLength, unListLength),
+ ItemIndex(ItemIndex, unItemIndex),
+ PostFilterFn,
+ parseComparer,
+ processPostFilters,
+ parsePredicate,
+ parseInt,
+ parseInfix,
+ parseRPN,
+ exprDesc,
+ showExpression,
+ verboseFilter,
+
+ -- * Parsers
+ Operand,
+ operandSpecs,
+ postFilterSpecs,
+ matcherSelectSpecs,
+ caseSelectSpecs,
+ operatorSpecs,
+
+ -- * Version
+ version,
+
+
+ -- * Output
+ output,
+ processOutput,
+
+ -- * Errors
+ Error
+
+ ) where
+
+import Control.Arrow (first, second)
+import Control.Applicative ((<*>), (<$>), pure, Applicative)
+import qualified Control.Monad.Exception.Synchronous as Ex
+import Data.Char (toUpper)
+import Data.Monoid ((<>))
+import Data.List (sortBy)
+import Data.Text (Text, pack)
+import qualified Data.Text as X
+import qualified Data.Text.IO as TIO
+import qualified Data.Time as Time
+import qualified System.Console.MultiArg as MA
+import qualified System.Console.MultiArg.Combinator as C
+import System.Console.MultiArg.Combinator (OptSpec)
+import Text.Parsec (parse)
+
+import qualified Penny.Copper.Parsec as Pc
+
+import qualified Penny.Lincoln.Predicates as P
+import qualified Penny.Lincoln.Queries as Q
+import qualified Penny.Lincoln.Predicates.Siblings as PS
+import qualified Data.Prednote.Pdct as E
+import qualified Penny.Lincoln as L
+import qualified System.Console.Rainbow as C
+import qualified Data.Prednote.Expressions as X
+
+import Text.Matchers (
+ CaseSensitive(Sensitive, Insensitive))
+import qualified Text.Matchers as TM
+
+#ifdef incabal
+import qualified Paths_penny as PPL
+#endif
+import qualified Data.Version as V
+
+-- | A multiline Text that holds an error message.
+type Error = Text
+
+-- | A serial indicating how a post relates to all other postings that
+-- made it through the filtering phase.
+newtype FilteredNum = FilteredNum { unFilteredNum :: L.Serial }
+ deriving Show
+
+-- | A serial indicating how a posting relates to all other postings
+-- that have been sorted.
+newtype SortedNum = SortedNum { unSortedNum :: L.Serial }
+ deriving Show
+
+-- | All metadata from Liberty.
+data LibertyMeta =
+ LibertyMeta { filteredNum :: FilteredNum
+ , sortedNum :: SortedNum }
+ deriving Show
+
+
+-- | Parses a list of tokens to obtain a predicate. Deals with an
+-- empty list of tokens by returning a predicate that is always
+-- True. Fails if the list of tokens is not empty and the parse fails.
+parsePredicate
+ :: X.ExprDesc
+ -> [X.Token a]
+ -> Ex.Exceptional Error (E.Pdct a)
+parsePredicate d ls = case ls of
+ [] -> return E.always
+ _ -> X.parseExpression d ls
+
+-- | Takes a list of transactions, splits them into PostingChild
+-- instances, filters them, post-filters them, sorts them, and places
+-- them in Box instances with Filtered serials. Also returns Chunks
+-- containing a description of the evalutation process.
+
+xactionsToFiltered
+
+ :: P.LPdct
+ -- ^ The predicate to filter the transactions
+
+ -> [PostFilterFn]
+ -- ^ Post filter specs
+
+ -> (L.Posting -> L.Posting -> Ordering)
+ -- ^ The sorter
+
+ -> [L.Transaction]
+ -- ^ The transactions to work on (probably parsed in from Copper)
+
+ -> ( (L.Amount L.Qty -> X.Text) -> [C.Chunk]
+ , [(LibertyMeta, L.Posting)])
+ -- ^ Sorted, filtered postings
+
+xactionsToFiltered pdct postFilts srtr
+ = second (processPostings srtr postFilts)
+ . mainFilter pdct
+ . concatMap L.transactionToPostings
+
+processPostings
+ :: (L.Posting -> L.Posting -> Ordering)
+ -> [PostFilterFn]
+ -> [L.Posting]
+ -> [(LibertyMeta, L.Posting)]
+processPostings srtr postFilters
+ = (map . first . uncurry $ LibertyMeta)
+ . addSortedNum
+ . sortBy (\p1 p2 -> srtr (snd p1) (snd p2))
+ . processPostFilters postFilters
+ . addFilteredNum
+
+mainFilter
+ :: P.LPdct
+ -> [L.Posting]
+ -> ((L.Amount L.Qty -> X.Text) -> [C.Chunk], [L.Posting])
+mainFilter pdct pstgs = (getChks, ps')
+ where
+ ps' = E.filter pdct pstgs
+ getChks fmt = fst $ E.verboseFilter (L.display fmt) indentAmt
+ False pdct pstgs
+
+
+addFilteredNum :: [a] -> [(FilteredNum, a)]
+addFilteredNum = L.serialItems (\s p -> (FilteredNum s, p))
+
+addSortedNum :: [(a, b)] -> [((a, SortedNum), b)]
+addSortedNum = L.serialItems (\s (a, b) -> ((a, SortedNum s), b))
+
+indentAmt :: E.IndentAmt
+indentAmt = 4
+
+type MatcherFactory
+ = CaseSensitive
+ -> Text
+ -> Ex.Exceptional Text TM.Matcher
+
+newtype ListLength = ListLength { unListLength :: Int }
+ deriving (Eq, Ord, Show)
+newtype ItemIndex = ItemIndex { unItemIndex :: Int }
+ deriving (Eq, Ord, Show)
+
+-- | Specifies options for the post-filter stage.
+type PostFilterFn = ListLength -> ItemIndex -> Bool
+
+
+processPostFilters :: [PostFilterFn] -> [a] -> [a]
+processPostFilters pfs ls = foldl processPostFilter ls pfs
+
+
+processPostFilter :: [a] -> PostFilterFn -> [a]
+processPostFilter as fn = map fst . filter fn' $ zipped where
+ len = ListLength $ length as
+ fn' (_, idx) = fn len (ItemIndex idx)
+ zipped = zip as [0..]
+
+
+------------------------------------------------------------
+-- Operands
+------------------------------------------------------------
+
+-- | Given a String from the command line which represents a pattern,
+-- the current case sensitivity, and a MatcherFactory, return a
+-- Matcher. Fails if the pattern is bad (e.g. it is not a valid
+-- regular expression).
+getMatcher
+ :: String
+ -> CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error TM.Matcher
+
+getMatcher s cs f
+ = Ex.mapException mkError
+ $ f cs (pack s)
+ where
+ mkError eMsg = "bad pattern: \"" <> pack s <> " - " <> eMsg
+ <> "\n"
+
+
+-- | Parses comparers given on command line to a function. Fails if
+-- the string given is invalid.
+parseComparer
+ :: String
+ -> (Ordering -> E.Pdct a)
+ -> Ex.Exceptional Error (E.Pdct a)
+parseComparer s f = Ex.fromMaybe ("bad comparer: " <> pack s <> "\n")
+ $ E.parseComparer (pack s) f
+
+-- | Parses a date from the command line. On failure, throws back the
+-- error message from the failed parse.
+parseDate :: String -> Ex.Exceptional Error Time.UTCTime
+parseDate arg =
+ Ex.mapExceptional err L.toUTC
+ . Ex.fromEither
+ . parse Pc.dateTime ""
+ . pack
+ $ arg
+ where
+ err msg = "bad date: \"" <> pack arg <> "\" - " <> (pack . show $ msg)
+
+type Operand = E.Pdct L.Posting
+
+-- | OptSpec for a date.
+date :: OptSpec (Ex.Exceptional Error Operand)
+date = C.OptSpec ["date"] ['d'] (C.TwoArg f)
+ where
+ f a1 a2 = do
+ utct <- parseDate a2
+ parseComparer a1 (flip P.date utct)
+
+
+current :: L.DateTime -> OptSpec Operand
+current dt = C.OptSpec ["current"] [] (C.NoArg f)
+ where
+ f = E.or [P.date LT (L.toUTC dt), P.date EQ (L.toUTC dt)]
+
+-- | Parses exactly one integer; fails if it cannot read exactly one.
+parseInt :: String -> Ex.Exceptional Error Int
+parseInt t =
+ case reads t of
+ ((i, ""):[]) -> return i
+ _ -> Ex.throw $ "could not parse integer: \"" <> pack t <> "\"\n"
+
+
+-- | Creates options that add an operand that matches the posting if a
+-- particluar field matches the pattern given.
+patternOption ::
+ String
+ -- ^ Long option
+
+ -> Maybe Char
+ -- ^ Short option, if included
+
+ -> (TM.Matcher -> P.LPdct)
+ -- ^ When applied to a Matcher, this function returns a predicate.
+
+ -> OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand )
+patternOption str mc f = C.OptSpec [str] so (C.OneArg g)
+ where
+ so = maybe [] (:[]) mc
+ g a1 cs fty = f <$> getMatcher a1 cs fty
+
+
+-- | The account option; matches if the pattern given matches the
+-- colon-separated account name.
+account :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand )
+account = C.OptSpec ["account"] "a" (C.OneArg f)
+ where
+ f a1 cs fty
+ = fmap P.account
+ $ getMatcher a1 cs fty
+
+
+-- | The account-level option; matches if the account at the given
+-- level matches.
+accountLevel :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand)
+accountLevel = C.OptSpec ["account-level"] "" (C.TwoArg f)
+ where
+ f a1 a2 cs fty
+ = P.accountLevel <$> parseInt a1 <*> getMatcher a2 cs fty
+
+
+-- | The accountAny option; returns True if the matcher given matches
+-- a single sub-account name at any level.
+accountAny :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand )
+accountAny = patternOption "account-any" Nothing P.accountAny
+
+-- | The payee option; returns True if the matcher matches the payee
+-- name.
+payee :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand )
+payee = patternOption "payee" (Just 'p') P.payee
+
+tag :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand)
+tag = patternOption "tag" (Just 't') P.tag
+
+number :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand )
+number = patternOption "number" (Just 'n') P.number
+
+flag :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand)
+flag = patternOption "flag" (Just 'f') P.flag
+
+commodity :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand)
+commodity = patternOption "commodity" (Just 'y') P.commodity
+
+filename :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand )
+filename = patternOption "filename" Nothing P.filename
+
+postingMemo :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand)
+postingMemo = patternOption "posting-memo" Nothing P.postingMemo
+
+transactionMemo :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand)
+transactionMemo = patternOption "transaction-memo"
+ Nothing P.transactionMemo
+
+debit :: OptSpec Operand
+debit = C.OptSpec ["debit"] [] (C.NoArg P.debit)
+
+credit :: OptSpec Operand
+credit = C.OptSpec ["credit"] [] (C.NoArg P.credit)
+
+qtyOption :: OptSpec (Ex.Exceptional Error Operand)
+qtyOption = C.OptSpec ["qty"] "q" (C.TwoArg f)
+ where
+ f a1 a2 = do
+ qt <- parseQty a2
+ parseComparer a1 (flip P.qty qt)
+ parseQty a = case parse Pc.unquotedQtyRepWithSpaces "" (pack a) of
+ Left _ -> Ex.throw $ "failed to parse quantity"
+ Right g -> pure . L.toQty $ g
+
+
+-- | Creates two options suitable for comparison of serial numbers,
+-- one for ascending, one for descending.
+serialOption ::
+
+ (L.Posting -> Maybe L.Serial)
+ -- ^ Function that, when applied to a Posting, returns the serial
+ -- you are interested in.
+
+ -> String
+ -- ^ Name of the command line option, such as @global-transaction@
+
+ -> ( OptSpec (Ex.Exceptional Error Operand)
+ , OptSpec (Ex.Exceptional Error Operand) )
+ -- ^ Parses both descending and ascending serial options.
+
+serialOption getSerial n = (osA, osD)
+ where
+ osA = C.OptSpec [n] []
+ (C.TwoArg (f n L.forward))
+ osD = let name = addPrefix "rev" n
+ in C.OptSpec [name] []
+ (C.TwoArg (f name L.backward))
+ f name getInt a1 a2 = do
+ num <- parseInt a2
+ let getPdct = E.compareByMaybe (pack . show $ num) (pack name) cmp
+ cmp l = case getSerial l of
+ Nothing -> Nothing
+ Just ser -> Just $ compare (getInt ser) num
+ parseComparer a1 getPdct
+
+
+-- | Creates two options suitable for comparison of sibling serial
+-- numbers. Similar to serialOption.
+siblingSerialOption
+ :: String
+ -- ^ Name of the command line option, such as @global-posting@
+
+ -> (Int -> Ordering -> E.Pdct L.Posting)
+ -- ^ Function that returns a Pdct for forward serial
+
+ -> (Int -> Ordering -> E.Pdct L.Posting)
+ -- ^ Function that returns a Pdct for reverse serial
+
+ -> ( OptSpec (Ex.Exceptional Error Operand)
+ , OptSpec (Ex.Exceptional Error Operand) )
+ -- ^ Parses both descending and ascending serial options.
+
+siblingSerialOption n fFwd fBak = (osA, osD)
+ where
+ osA = C.OptSpec ["s-" ++ n] [] (C.TwoArg (f fFwd))
+ osD = let name = addPrefix "rev" n
+ in C.OptSpec ["s-" ++ name] [] (C.TwoArg (f fBak))
+ f getPdct a1 a2 = do
+ num <- parseInt a2
+ parseComparer a1 (getPdct num)
+
+
+-- | Takes a string, adds a prefix and capitalizes the first letter of
+-- the old string. e.g. applied to "rev" and "globalTransaction",
+-- returns "revGlobalTransaction".
+addPrefix :: String -> String -> String
+addPrefix pre suf = pre ++ suf' where
+ suf' = case suf of
+ "" -> ""
+ x:xs -> toUpper x : xs
+
+globalTransaction :: ( OptSpec (Ex.Exceptional Error Operand)
+ , OptSpec (Ex.Exceptional Error Operand) )
+globalTransaction =
+ let f = fmap L.unGlobalTransaction . Q.globalTransaction
+ in serialOption f "globalTransaction"
+
+globalPosting :: ( OptSpec (Ex.Exceptional Error Operand)
+ , OptSpec (Ex.Exceptional Error Operand) )
+globalPosting =
+ let f = fmap L.unGlobalPosting . Q.globalPosting
+ in serialOption f "globalPosting"
+
+filePosting :: ( OptSpec (Ex.Exceptional Error Operand)
+ , OptSpec (Ex.Exceptional Error Operand) )
+filePosting =
+ let f = fmap L.unFilePosting . Q.filePosting
+ in serialOption f "filePosting"
+
+fileTransaction :: ( OptSpec (Ex.Exceptional Error Operand)
+ , OptSpec (Ex.Exceptional Error Operand) )
+fileTransaction =
+ let f = fmap L.unFileTransaction . Q.fileTransaction
+ in serialOption f "fileTransaction"
+
+-- | All operand OptSpec.
+operandSpecs
+ :: L.DateTime
+ -> [OptSpec (CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand)]
+
+operandSpecs dt =
+ [ fmap (const . const) date
+ , fmap (const . const . pure) (current dt)
+ , account
+ , accountLevel
+ , accountAny
+ , payee
+ , tag
+ , number
+ , flag
+ , commodity
+ , postingMemo
+ , transactionMemo
+ , filename
+ , fmap (const . const . pure) debit
+ , fmap (const . const . pure) credit
+ , fmap (const . const) qtyOption
+
+ , sAccount
+ , sAccountLevel
+ , sAccountAny
+ , sPayee
+ , sTag
+ , sNumber
+ , sFlag
+ , sCommodity
+ , sPostingMemo
+ , fmap (const . const . pure) sDebit
+ , fmap (const . const. pure) sCredit
+ , fmap (const . const) sQtyOption
+ ]
+ ++ serialSpecs
+
+serialSpecs :: [OptSpec (CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand)]
+serialSpecs
+ = concat
+ $ [unDouble]
+ <*> [ globalTransaction, globalPosting,
+ filePosting, fileTransaction,
+ sGlobalPosting, sFilePosting,
+ sGlobalTransaction, sFileTransaction ]
+
+unDouble
+ :: Functor f
+ => (f (Ex.Exceptional Error a),
+ f (Ex.Exceptional Error a ))
+ -> [ f (x -> y -> Ex.Exceptional Error a) ]
+unDouble (o1, o2) = [fmap (const . const) o1, fmap (const . const) o2]
+
+
+------------------------------------------------------------
+-- Post filters
+------------------------------------------------------------
+
+-- | The user passed a bad number for the head or tail option. The
+-- argument is the bad number passed.
+data BadHeadTailError = BadHeadTailError Text
+ deriving Show
+
+optHead :: OptSpec (Ex.Exceptional Error PostFilterFn)
+optHead = C.OptSpec ["head"] [] (C.OneArg f)
+ where
+ f a = do
+ num <- parseInt a
+ let g _ ii = ii < (ItemIndex num)
+ return g
+
+optTail :: OptSpec (Ex.Exceptional Error PostFilterFn)
+optTail = C.OptSpec ["tail"] [] (C.OneArg f)
+ where
+ f a = do
+ num <- parseInt a
+ let g (ListLength len) (ItemIndex ii) = ii >= len - num
+ return g
+
+postFilterSpecs
+ :: ( OptSpec (Ex.Exceptional Error PostFilterFn)
+ , OptSpec (Ex.Exceptional Error PostFilterFn))
+postFilterSpecs = (optHead, optTail)
+
+------------------------------------------------------------
+-- Matcher control
+------------------------------------------------------------
+
+parseInsensitive :: OptSpec CaseSensitive
+parseInsensitive =
+ C.OptSpec ["case-insensitive"] ['i'] (C.NoArg Insensitive)
+
+
+parseSensitive :: OptSpec CaseSensitive
+parseSensitive =
+ C.OptSpec ["case-sensitive"] ['I'] (C.NoArg Sensitive)
+
+
+within :: OptSpec MatcherFactory
+within =
+ C.OptSpec ["within"] "w" . C.NoArg $ \c t ->
+ return (TM.within c t)
+
+pcre :: OptSpec MatcherFactory
+pcre = C.OptSpec ["pcre"] "r" (C.NoArg TM.pcre)
+
+posix :: OptSpec MatcherFactory
+posix = C.OptSpec ["posix"] "" (C.NoArg TM.tdfa)
+
+exact :: OptSpec MatcherFactory
+exact = C.OptSpec ["exact"] "x" . C.NoArg $ \c t ->
+ return (TM.exact c t)
+
+matcherSelectSpecs :: [OptSpec MatcherFactory]
+matcherSelectSpecs = [within, pcre, posix, exact]
+
+caseSelectSpecs :: [OptSpec CaseSensitive]
+caseSelectSpecs = [parseInsensitive, parseSensitive]
+
+------------------------------------------------------------
+-- Operators
+------------------------------------------------------------
+
+-- | Open parentheses
+open :: OptSpec (X.Token a)
+open = C.OptSpec ["open"] "(" (C.NoArg X.openParen)
+
+-- | Close parentheses
+close :: OptSpec (X.Token a)
+close = C.OptSpec ["close"] ")" (C.NoArg X.closeParen)
+
+-- | and operator
+parseAnd :: OptSpec (X.Token a)
+parseAnd = C.OptSpec ["and"] "A" (C.NoArg X.opAnd)
+
+-- | or operator
+parseOr :: OptSpec (X.Token a)
+parseOr = C.OptSpec ["or"] "O" (C.NoArg X.opOr)
+
+-- | not operator
+parseNot :: OptSpec (X.Token a)
+parseNot = C.OptSpec ["not"] "N" (C.NoArg X.opNot)
+
+operatorSpecs :: [OptSpec (X.Token a)]
+operatorSpecs =
+ [open, close, parseAnd, parseOr, parseNot]
+
+-- Infix and RPN expression selectors
+
+parseInfix :: OptSpec X.ExprDesc
+parseInfix = C.OptSpec ["infix"] "" (C.NoArg X.Infix)
+
+parseRPN :: OptSpec X.ExprDesc
+parseRPN = C.OptSpec ["rpn"] "" (C.NoArg X.RPN)
+
+-- | Both Infix and RPN options.
+exprDesc :: [OptSpec X.ExprDesc]
+exprDesc = [ parseInfix, parseRPN ]
+
+showExpression :: OptSpec ()
+showExpression = C.OptSpec ["show-expression"] "" (C.NoArg ())
+
+verboseFilter :: OptSpec ()
+verboseFilter = C.OptSpec ["verbose-filter"] "" (C.NoArg ())
+
+--
+-- Siblings
+--
+
+sGlobalPosting :: ( OptSpec (Ex.Exceptional Error Operand)
+ , OptSpec (Ex.Exceptional Error Operand) )
+sGlobalPosting =
+ siblingSerialOption "globalPosting"
+ PS.fwdGlobalPosting PS.backGlobalPosting
+
+sFilePosting :: ( OptSpec (Ex.Exceptional Error Operand)
+ , OptSpec (Ex.Exceptional Error Operand) )
+sFilePosting =
+ siblingSerialOption "filePosting"
+ PS.fwdFilePosting PS.backFilePosting
+
+sGlobalTransaction :: ( OptSpec (Ex.Exceptional Error Operand)
+ , OptSpec (Ex.Exceptional Error Operand) )
+sGlobalTransaction =
+ siblingSerialOption "globalTransaction"
+ PS.fwdGlobalTransaction PS.backGlobalTransaction
+
+sFileTransaction :: ( OptSpec (Ex.Exceptional Error Operand)
+ , OptSpec (Ex.Exceptional Error Operand) )
+sFileTransaction =
+ siblingSerialOption "filePosting"
+ PS.fwdFileTransaction PS.backFileTransaction
+
+
+sAccount :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand )
+sAccount = C.OptSpec ["s-account"] "" (C.OneArg f)
+ where
+ f a1 cs fty = fmap PS.account
+ $ getMatcher a1 cs fty
+
+sAccountLevel :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand )
+sAccountLevel = C.OptSpec ["s-account-level"] "" (C.TwoArg f)
+ where
+ f a1 a2 cs fty
+ = PS.accountLevel <$> parseInt a1 <*> getMatcher a2 cs fty
+
+sAccountAny :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand )
+sAccountAny = patternOption "s-account-any" Nothing PS.accountAny
+
+-- | The payee option; returns True if the matcher matches the payee
+-- name.
+sPayee :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand )
+sPayee = patternOption "s-payee" (Just 'p') PS.payee
+
+sTag :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand)
+sTag = patternOption "s-tag" (Just 't') PS.tag
+
+sNumber :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand )
+sNumber = patternOption "s-number" Nothing PS.number
+
+sFlag :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand)
+sFlag = patternOption "s-flag" Nothing PS.flag
+
+sCommodity :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand)
+sCommodity = patternOption "s-commodity" Nothing PS.commodity
+
+sPostingMemo :: OptSpec ( CaseSensitive
+ -> MatcherFactory
+ -> Ex.Exceptional Error Operand)
+sPostingMemo = patternOption "s-posting-memo" Nothing PS.postingMemo
+
+sDebit :: OptSpec Operand
+sDebit = C.OptSpec ["s-debit"] [] (C.NoArg PS.debit)
+
+sCredit :: OptSpec Operand
+sCredit = C.OptSpec ["s-credit"] [] (C.NoArg PS.credit)
+
+sQtyOption :: OptSpec (Ex.Exceptional Error Operand)
+sQtyOption = C.OptSpec ["s-qty"] [] (C.TwoArg f)
+ where
+ f a1 a2 = do
+ qt <- parseQty a2
+ parseComparer a1 (flip PS.qty qt)
+ parseQty a = case parse Pc.unquotedQtyRepWithSpaces "" (pack a) of
+ Left _ -> Ex.throw "could not parse quantity"
+ Right g -> pure . L.toQty $ g
+
+--
+-- Versions
+--
+
+-- | Prints the binary's version and the version of the library, and exits successfully.
+
+version
+ :: V.Version
+ -> String
+ -- ^ Program name
+ -> String
+version v pn = unlines
+ [ pn ++ " version " ++ V.showVersion v
+#ifdef incabal
+ , "using version " ++ V.showVersion PPL.version
+#else
+ , "using testing version"
+#endif
+ ++ " of penny-lib"
+ ]
+
+-- | An option for where the user would like to send output.
+output :: MA.OptSpec (X.Text -> IO ())
+output = MA.OptSpec ["output"] "o" . MA.OneArg $ \s ->
+ if s == "-"
+ then TIO.putStr
+ else TIO.writeFile s
+
+
+-- | Given a list of output options, returns a single IO action to
+-- write to all given files. If the list was empty, returns an IO
+-- action that writes to standard output.
+
+processOutput :: [X.Text -> IO ()] -> X.Text -> IO ()
+processOutput ls x =
+ if null ls
+ then TIO.putStr x
+ else sequence_ . map ($ x) $ ls
+
diff --git a/lib/Penny/Lincoln.hs b/lib/Penny/Lincoln.hs
new file mode 100644
index 0000000..6423b8d
--- /dev/null
+++ b/lib/Penny/Lincoln.hs
@@ -0,0 +1,77 @@
+-- | Lincoln - the Penny core
+--
+-- Penny's core types and classes are here. This module re-exports the
+-- most useful things. For more details you will want to look at the
+-- sub-modules. Also, not all types and functions are re-exported due
+-- to naming conflicts. In particular, neither
+-- "Penny.Lincoln.Predicates" nor "Penny.Lincoln.Queries" is exported
+-- from here due to the blizzard of name conflicts that would result.
+module Penny.Lincoln
+ ( module Penny.Lincoln.Balance
+ , module Penny.Lincoln.Bits
+ , module Penny.Lincoln.Builders
+ , module Penny.Lincoln.Ents
+ , module Penny.Lincoln.Equivalent
+ , module Penny.Lincoln.HasText
+ , module Penny.Lincoln.Matchers
+ , module Penny.Lincoln.PriceDb
+ , module Penny.Lincoln.Serial
+ , display
+ ) where
+
+import Penny.Lincoln.Bits
+import Penny.Lincoln.Ents
+import Penny.Lincoln.Balance
+import Penny.Lincoln.Builders
+import Penny.Lincoln.Equivalent
+import Penny.Lincoln.HasText
+import Penny.Lincoln.Matchers
+import Penny.Lincoln.PriceDb
+import Penny.Lincoln.Serial
+
+import Data.List (intersperse)
+import Data.Text (Text)
+import qualified Data.Text as X
+import qualified Penny.Lincoln.Queries as Q
+import qualified Data.Time as Time
+import System.Locale (defaultTimeLocale)
+
+--
+-- Display
+--
+
+-- | Displays a PostFam in a one line format.
+--
+-- Format:
+--
+-- File LineNo Date Payee Acct DrCr Cmdty Qty
+display
+ :: (Amount Qty -> X.Text)
+ -- ^ How to format Qty that do not have a QtyRep
+ -> Posting
+ -> Text
+display fmt p = X.pack $ concat (intersperse " " ls)
+ where
+ ls = [file, lineNo, dt, pye, acct, dc, cmdty, qt]
+ file = maybe (labelNo "filename") (X.unpack . unFilename)
+ (fmap tFilename . tlFileMeta . fst . unPosting $ p)
+ lineNo = maybe (labelNo "line number")
+ (show . unPostingLine)
+ (Q.postingLine p)
+ dateFormat = "%Y-%m-%d %T %z"
+ dt = Time.formatTime defaultTimeLocale dateFormat
+ . Time.utctDay
+ . toUTC
+ . Q.dateTime
+ $ p
+ pye = maybe (labelNo "payee")
+ (X.unpack . text) (Q.payee p)
+ acct = X.unpack . X.intercalate (X.singleton ':')
+ . map unSubAccount . unAccount . Q.account $ p
+ dc = case Q.drCr p of
+ Debit -> "Dr"
+ Credit -> "Cr"
+ cmdty = X.unpack . unCommodity . Q.commodity $ p
+ getFmt q = fmt $ Amount q (Q.commodity p)
+ qt = X.unpack . either showQtyRep getFmt . Q.eiQty $ p
+ labelNo s = "(no " ++ s ++ ")"
diff --git a/lib/Penny/Lincoln/Balance.hs b/lib/Penny/Lincoln/Balance.hs
new file mode 100644
index 0000000..983b406
--- /dev/null
+++ b/lib/Penny/Lincoln/Balance.hs
@@ -0,0 +1,116 @@
+module Penny.Lincoln.Balance (
+ Balance
+ , unBalance
+ , Balanced(Balanced, Inferable, NotInferable)
+ , balanced
+ , isInferable
+ , entryToBalance
+ , entriesToBalanced
+ , removeZeroCommodities
+ , BottomLine(Zero, NonZero)
+ , Column(Column, colDrCr, colQty)
+ ) where
+
+import Data.Map ( Map )
+import qualified Data.Map as M
+import Data.Monoid ( Monoid, mempty, mappend, mconcat )
+
+import Penny.Lincoln.Bits (
+ add, difference, Difference(LeftBiggerBy, RightBiggerBy, Equal))
+import qualified Penny.Lincoln.Bits as B
+
+-- | A balance summarizes several entries. You do not create a Balance
+-- directly. Instead, use 'entryToBalance'.
+newtype Balance = Balance (Map B.Commodity BottomLine)
+ deriving (Show, Eq)
+
+-- | Returns a map where the keys are the commodities in the balance
+-- and the values are the balance for each commodity. If there is no
+-- balance at all, this map can be empty.
+unBalance :: Balance -> Map B.Commodity BottomLine
+unBalance (Balance m) = m
+
+-- | Returned by 'balanced'.
+data Balanced = Balanced
+ | Inferable (B.Entry B.Qty)
+ | NotInferable
+ deriving (Show, Eq)
+
+-- | Computes whether a Balance map is Balanced.
+--
+-- > balanced mempty == Balanced
+balanced :: Balance -> Balanced
+balanced (Balance m) = M.foldrWithKey f Balanced m where
+ f c n b = case n of
+ Zero -> b
+ (NonZero col) -> case b of
+ Balanced -> let
+ dc = case colDrCr col of
+ B.Debit -> B.Credit
+ B.Credit -> B.Debit
+ q = colQty col
+ in Inferable (B.Entry dc (B.Amount q c))
+ _ -> NotInferable
+
+isInferable :: Balanced -> Bool
+isInferable (Inferable _) = True
+isInferable _ = False
+
+-- | Converts an Entry to a Balance.
+entryToBalance :: B.HasQty q => B.Entry q -> Balance
+entryToBalance (B.Entry dc am) = Balance $ M.singleton c no where
+ c = B.commodity am
+ no = NonZero (Column dc (B.toQty . B.qty $ am))
+
+-- | Converts multiple Entries to a Balanced.
+entriesToBalanced :: B.HasQty q => [B.Entry q] -> Balanced
+entriesToBalanced
+ = balanced
+ . mconcat
+ . map entryToBalance
+
+data BottomLine = Zero
+ | NonZero Column
+ deriving (Show, Eq)
+
+instance Monoid BottomLine where
+ mempty = Zero
+ mappend n1 n2 = case (n1, n2) of
+ (Zero, Zero) -> Zero
+ (Zero, (NonZero c)) -> NonZero c
+ ((NonZero c), Zero) -> NonZero c
+ ((NonZero c1), (NonZero c2)) ->
+ let (Column dc1 q1) = c1
+ (Column dc2 q2) = c2
+ in if dc1 == dc2
+ then NonZero $ Column dc1 (q1 `add` q2)
+ else case difference q1 q2 of
+ LeftBiggerBy diff ->
+ NonZero $ Column dc1 diff
+ RightBiggerBy diff ->
+ NonZero $ Column dc2 diff
+ Equal -> Zero
+
+data Column = Column { colDrCr :: B.DrCr
+ , colQty :: B.Qty }
+ deriving (Show, Eq)
+
+
+-- | Add two Balances together. Commodities are never removed from the
+-- balance, even if their balance is zero. Instead, they are left in
+-- the balance. Sometimes you want to know that a commodity was in the
+-- account but its balance is now zero.
+instance Monoid Balance where
+ mempty = Balance M.empty
+ mappend (Balance t1) (Balance t2) =
+ Balance $ M.unionWith mappend t1 t2
+
+
+-- | Removes zero balances from a Balance.
+removeZeroCommodities :: Balance -> Balance
+removeZeroCommodities (Balance m) =
+ let p b = case b of
+ Zero -> False
+ _ -> True
+ m' = M.filter p m
+ in Balance m'
diff --git a/lib/Penny/Lincoln/Bits.hs b/lib/Penny/Lincoln/Bits.hs
new file mode 100644
index 0000000..ccb3c2a
--- /dev/null
+++ b/lib/Penny/Lincoln/Bits.hs
@@ -0,0 +1,164 @@
+-- | Essential data types used to make Transactions and Postings.
+module Penny.Lincoln.Bits
+ ( module Penny.Lincoln.Bits.Open
+ , module Penny.Lincoln.Bits.DateTime
+ , module Penny.Lincoln.Bits.Price
+ , module Penny.Lincoln.Bits.Qty
+ , PricePoint ( .. )
+
+ -- * Aggregates
+ , TopLineCore(..)
+ , emptyTopLineCore
+ , TopLineFileMeta(..)
+ , TopLineData(..)
+ , emptyTopLineData
+ , PostingCore(..)
+ , emptyPostingCore
+ , PostingFileMeta(..)
+ , PostingData(..)
+ , emptyPostingData
+ ) where
+
+
+import Data.Monoid (mconcat)
+import Penny.Lincoln.Bits.Open
+import Penny.Lincoln.Bits.DateTime
+import Penny.Lincoln.Bits.Qty
+import Penny.Lincoln.Bits.Price
+
+import qualified Penny.Lincoln.Bits.Open as O
+import qualified Penny.Lincoln.Bits.DateTime as DT
+import qualified Penny.Lincoln.Bits.Price as Pr
+import qualified Penny.Lincoln.Equivalent as Ev
+import Penny.Lincoln.Equivalent ((==~))
+
+data PricePoint = PricePoint { dateTime :: DT.DateTime
+ , price :: Pr.Price
+ , ppSide :: Maybe O.Side
+ , ppSpaceBetween :: Maybe O.SpaceBetween
+ , priceLine :: Maybe O.PriceLine }
+ deriving (Eq, Show)
+
+
+-- | PricePoint are equivalent if the dateTime and the Price are
+-- equivalent. Other elements of the PricePoint are ignored.
+instance Ev.Equivalent PricePoint where
+ equivalent (PricePoint dx px _ _ _) (PricePoint dy py _ _ _) =
+ dx ==~ dy && px ==~ py
+ compareEv (PricePoint dx px _ _ _) (PricePoint dy py _ _ _) =
+ mconcat [ Ev.compareEv dx dy
+ , Ev.compareEv px py ]
+
+-- | All the data that a TopLine might have.
+data TopLineData = TopLineData
+ { tlCore :: TopLineCore
+ , tlFileMeta :: Maybe TopLineFileMeta
+ , tlGlobal :: Maybe O.GlobalTransaction
+ } deriving (Eq, Show)
+
+emptyTopLineData :: DT.DateTime -> TopLineData
+emptyTopLineData dt = TopLineData (emptyTopLineCore dt) Nothing Nothing
+
+-- | Every TopLine has this data.
+data TopLineCore = TopLineCore
+ { tDateTime :: DT.DateTime
+ , tNumber :: Maybe O.Number
+ , tFlag :: Maybe O.Flag
+ , tPayee :: Maybe O.Payee
+ , tMemo :: Maybe O.Memo
+ } deriving (Eq, Show)
+
+-- | TopLineCore are equivalent if their dates are equivalent and if
+-- everything else is equal.
+instance Ev.Equivalent TopLineCore where
+ equivalent x y =
+ tDateTime x ==~ tDateTime y
+ && tNumber x == tNumber y
+ && tFlag x == tFlag y
+ && tPayee x == tPayee y
+ && tMemo x == tMemo y
+
+ compareEv x y = mconcat
+ [ Ev.compareEv (tDateTime x) (tDateTime y)
+ , compare (tNumber x) (tNumber y)
+ , compare (tFlag x) (tFlag y)
+ , compare (tPayee x) (tPayee y)
+ , compare (tMemo x) (tMemo y)
+ ]
+
+emptyTopLineCore :: DT.DateTime -> TopLineCore
+emptyTopLineCore dt = TopLineCore dt Nothing Nothing Nothing Nothing
+
+-- | TopLines from files have this metadata.
+data TopLineFileMeta = TopLineFileMeta
+ { tFilename :: O.Filename
+ , tTopLineLine :: O.TopLineLine
+ , tTopMemoLine :: Maybe O.TopMemoLine
+ , tFileTransaction :: O.FileTransaction
+ } deriving (Eq, Show)
+
+
+-- | All Postings have this data.
+data PostingCore = PostingCore
+ { pPayee :: Maybe O.Payee
+ , pNumber :: Maybe O.Number
+ , pFlag :: Maybe O.Flag
+ , pAccount :: O.Account
+ , pTags :: O.Tags
+ , pMemo :: Maybe O.Memo
+ , pSide :: Maybe O.Side
+ , pSpaceBetween :: Maybe O.SpaceBetween
+ } deriving (Eq, Show)
+
+-- | Two PostingCore are equivalent if the Tags are equivalent and the
+-- other data is equal, exlucing the Side and the SpaceBetween, which are not considered at all.
+instance Ev.Equivalent PostingCore where
+ equivalent (PostingCore p1 n1 f1 a1 t1 m1 _ _)
+ (PostingCore p2 n2 f2 a2 t2 m2 _ _)
+ = p1 == p2 && n1 == n2 && f1 == f2
+ && a1 == a2 && t1 ==~ t2 && m1 == m2
+
+ compareEv (PostingCore p1 n1 f1 a1 t1 m1 _ _)
+ (PostingCore p2 n2 f2 a2 t2 m2 _ _)
+ = mconcat
+ [ compare p1 p2
+ , compare n1 n2
+ , compare f1 f2
+ , compare a1 a2
+ , Ev.compareEv t1 t2
+ , compare m1 m2
+ ]
+
+emptyPostingCore :: O.Account -> PostingCore
+emptyPostingCore ac = PostingCore
+ { pPayee = Nothing
+ , pNumber = Nothing
+ , pFlag = Nothing
+ , pAccount = ac
+ , pTags = O.Tags []
+ , pMemo = Nothing
+ , pSide = Nothing
+ , pSpaceBetween = Nothing
+ }
+
+-- | Postings from files have this additional data.
+data PostingFileMeta = PostingFileMeta
+ { pPostingLine :: O.PostingLine
+ , pFilePosting :: O.FilePosting
+ } deriving (Eq, Show)
+
+
+-- | All the data that a Posting might have.
+data PostingData = PostingData
+ { pdCore :: PostingCore
+ , pdFileMeta :: Maybe PostingFileMeta
+ , pdGlobal :: Maybe O.GlobalPosting
+ } deriving (Eq, Show)
+
+emptyPostingData :: O.Account -> PostingData
+emptyPostingData ac = PostingData
+ { pdCore = emptyPostingCore ac
+ , pdFileMeta = Nothing
+ , pdGlobal = Nothing
+ }
+
diff --git a/lib/Penny/Lincoln/Bits/DateTime.hs b/lib/Penny/Lincoln/Bits/DateTime.hs
new file mode 100644
index 0000000..c165e9c
--- /dev/null
+++ b/lib/Penny/Lincoln/Bits/DateTime.hs
@@ -0,0 +1,157 @@
+module Penny.Lincoln.Bits.DateTime
+ ( TimeZoneOffset ( offsetToMins )
+ , minsToOffset
+ , noOffset
+ , Hours ( unHours )
+ , intToHours
+ , zeroHours
+ , Minutes ( unMinutes )
+ , intToMinutes
+ , zeroMinutes
+ , Seconds ( unSeconds )
+ , intToSeconds
+ , zeroSeconds
+ , midnight
+ , DateTime ( .. )
+ , dateTimeMidnightUTC
+ , toUTC
+ , toZonedTime
+ , fromZonedTime
+ , sameInstant
+ , showDateTime
+ ) where
+
+import qualified Data.Time as T
+import qualified Penny.Lincoln.Equivalent as Ev
+
+-- | The number of minutes that this timezone is offset from UTC. Can
+-- be positive, negative, or zero.
+newtype TimeZoneOffset = TimeZoneOffset { offsetToMins :: Int }
+ deriving (Eq, Ord, Show)
+
+-- | Convert minutes to a time zone offset. I'm having a hard time
+-- deciding whether to be liberal or strict in what to accept
+-- here. Currently it is somewhat strict in that it will fail if
+-- absolute value is greater than 840 minutes; currently the article
+-- at http://en.wikipedia.org/wiki/List_of_time_zones_by_UTC_offset
+-- says there is no offset greater than 14 hours, or 840 minutes.
+minsToOffset :: Int -> Maybe TimeZoneOffset
+minsToOffset m = if abs m > 840
+ then Nothing
+ else Just $ TimeZoneOffset m
+
+noOffset :: TimeZoneOffset
+noOffset = TimeZoneOffset 0
+
+newtype Hours = Hours { unHours :: Int }
+ deriving (Eq, Ord, Show)
+
+newtype Minutes = Minutes { unMinutes :: Int }
+ deriving (Eq, Ord, Show)
+
+newtype Seconds = Seconds { unSeconds :: Int }
+ deriving (Eq, Ord, Show)
+
+-- | succeeds if 0 <= x < 24
+intToHours :: Int -> Maybe Hours
+intToHours h =
+ if h >= 0 && h < 24 then Just . Hours $ h else Nothing
+
+zeroHours :: Hours
+zeroHours = Hours 0
+
+-- | succeeds if 0 <= x < 60
+intToMinutes :: Int -> Maybe Minutes
+intToMinutes m =
+ if m >= 0 && m < 60 then Just . Minutes $ m else Nothing
+
+zeroMinutes :: Minutes
+zeroMinutes = Minutes 0
+
+-- | succeeds if 0 <= x < 61 (to allow for leap seconds)
+intToSeconds :: Int -> Maybe Seconds
+intToSeconds s =
+ if s >= 0 && s < 61
+ then Just . Seconds $ s
+ else Nothing
+
+zeroSeconds :: Seconds
+zeroSeconds = Seconds 0
+
+midnight :: (Hours, Minutes, Seconds)
+midnight = (zeroHours, zeroMinutes, zeroSeconds)
+
+-- | A DateTime is a a local date and time, along with a time zone
+-- offset. The Eq and Ord instances are derived; therefore, two
+-- DateTime instances will not be equivalent if the time zone offsets
+-- are different, even if they are the same instant. To compare one
+-- DateTime to another, you probably want to use 'toUTC' and compare
+-- those. To see if two DateTime are the same instant, use
+-- 'sameInstant'.
+data DateTime = DateTime
+ { day :: T.Day
+ , hours :: Hours
+ , minutes :: Minutes
+ , seconds :: Seconds
+ , timeZone :: TimeZoneOffset
+ } deriving (Eq, Ord, Show)
+
+dateTimeMidnightUTC :: T.Day -> DateTime
+dateTimeMidnightUTC d = DateTime d h m s z
+ where
+ (h, m, s) = midnight
+ z = noOffset
+
+toZonedTime :: DateTime -> T.ZonedTime
+toZonedTime dt = T.ZonedTime lt tz
+ where
+ d = day dt
+ lt = T.LocalTime d tod
+ tod = T.TimeOfDay (unHours . hours $ dt) (unMinutes . minutes $ dt)
+ (fromIntegral . unSeconds . seconds $ dt)
+ tz = T.TimeZone (offsetToMins . timeZone $ dt) False ""
+
+fromZonedTime :: T.ZonedTime -> Maybe DateTime
+fromZonedTime (T.ZonedTime (T.LocalTime d tod) tz) = do
+ h <- intToHours . T.todHour $ tod
+ m <- intToMinutes . T.todMin $ tod
+ let (sWhole, _) = properFraction . T.todSec $ tod
+ s <- intToSeconds sWhole
+ tzo <- minsToOffset . T.timeZoneMinutes $ tz
+ return $ DateTime d h m s tzo
+
+toUTC :: DateTime -> T.UTCTime
+toUTC dt = T.localTimeToUTC tz lt
+ where
+ tz = T.minutesToTimeZone . offsetToMins . timeZone $ dt
+ tod = T.TimeOfDay (unHours h) (unMinutes m)
+ (fromIntegral . unSeconds $ s)
+ DateTime d h m s _ = dt
+ lt = T.LocalTime d tod
+
+-- | Are these DateTimes the same instant in time, after adjusting for
+-- local timezones?
+
+sameInstant :: DateTime -> DateTime -> Bool
+sameInstant t1 t2 = toUTC t1 == toUTC t2
+
+instance Ev.Equivalent DateTime where
+ equivalent = sameInstant
+ compareEv x y = compare (toUTC x) (toUTC y)
+
+-- | Shows a DateTime in a pretty way.
+showDateTime :: DateTime -> String
+showDateTime (DateTime d h m s tz) =
+ ds ++ " " ++ hmss ++ " " ++ showOffset
+ where
+ ds = show d
+ hmss = hs ++ ":" ++ ms ++ ":" ++ ss
+ hs = pad0 . show . unHours $ h
+ ms = pad0 . show . unMinutes $ m
+ ss = pad0 . show . unSeconds $ s
+ pad0 str = if length str < 2 then '0':str else str
+ showOffset =
+ let (zoneHr, zoneMin) = abs (offsetToMins tz) `divMod` 60
+ sign = if offsetToMins tz < 0 then "-" else "+"
+ in sign ++ pad0 (show zoneHr) ++ pad0 (show zoneMin)
+
diff --git a/lib/Penny/Lincoln/Bits/Open.hs b/lib/Penny/Lincoln/Bits/Open.hs
new file mode 100644
index 0000000..976bd8b
--- /dev/null
+++ b/lib/Penny/Lincoln/Bits/Open.hs
@@ -0,0 +1,162 @@
+-- | These are the bits that are "open"; that is, their constructors
+-- are exported. This includes most bits. Some bits that have open
+-- constructors are not in this module because they include other bits
+-- that do not have exported constructors.
+
+module Penny.Lincoln.Bits.Open where
+
+import Data.List (sort)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as X
+import qualified Penny.Lincoln.Equivalent as Ev
+import Penny.Lincoln.Equivalent ((==~))
+import qualified Penny.Lincoln.Serial as S
+
+newtype SubAccount =
+ SubAccount { unSubAccount :: Text }
+ deriving (Eq, Ord, Show)
+
+newtype Account = Account { unAccount :: [SubAccount] }
+ deriving (Eq, Show, Ord)
+
+data Amount q = Amount
+ { qty :: q
+ , commodity :: Commodity }
+ deriving (Eq, Show, Ord)
+
+instance Functor Amount where
+ fmap f (Amount q c) = Amount (f q) c
+
+instance Ev.Equivalent q => Ev.Equivalent (Amount q) where
+ equivalent (Amount q1 c1) (Amount q2 c2) =
+ q1 ==~ q2 && c1 == c2
+ compareEv (Amount q1 c1) (Amount q2 c2) =
+ Ev.compareEv q1 q2 <> c1 `compare` c2
+
+newtype Commodity =
+ Commodity { unCommodity :: Text }
+ deriving (Eq, Ord, Show)
+
+data DrCr = Debit | Credit deriving (Eq, Show, Ord)
+
+
+-- | Debit returns Credit; Credit returns Debit
+opposite :: DrCr -> DrCr
+opposite d = case d of
+ Debit -> Credit
+ Credit -> Debit
+
+data Entry q = Entry
+ { drCr :: DrCr
+ , amount :: Amount q }
+ deriving (Eq, Show, Ord)
+
+instance Functor Entry where
+ fmap f (Entry d a) = Entry d (fmap f a)
+
+instance Ev.Equivalent q => Ev.Equivalent (Entry q) where
+ equivalent (Entry d1 a1) (Entry d2 a2) =
+ d1 == d2 && a1 ==~ a2
+ compareEv (Entry d1 a1) (Entry d2 a2) =
+ d1 `compare` d2 <> Ev.compareEv a1 a2
+
+newtype Flag = Flag { unFlag :: Text }
+ deriving (Eq, Show, Ord)
+
+-- | There is one item in the list for each line of the memo. Do not
+-- include newlines in the texts themselves. However there is nothing
+-- to enforce this convention.
+newtype Memo = Memo { unMemo :: [Text] }
+ deriving (Eq, Show, Ord)
+
+newtype Number = Number { unNumber :: Text }
+ deriving (Eq, Show, Ord)
+
+newtype Payee = Payee { unPayee :: Text }
+ deriving (Eq, Show, Ord)
+
+newtype Tag = Tag { unTag :: Text }
+ deriving (Eq, Show, Ord)
+
+newtype Tags = Tags { unTags :: [Tag] }
+ deriving (Eq, Show, Ord)
+
+-- | Tags are equivalent if they have the same tags (even if in a
+-- different order).
+instance Ev.Equivalent Tags where
+ equivalent (Tags t1) (Tags t2) = sort t1 == sort t2
+ compareEv (Tags t1) (Tags t2) =
+ compare (sort t1) (sort t2)
+
+-- Metadata
+
+-- | The line number that the TopLine starts on (excluding the memo
+-- accompanying the TopLine).
+newtype TopLineLine = TopLineLine { unTopLineLine :: Int }
+ deriving (Eq, Show)
+
+-- | The line number that the memo accompanying the TopLine starts on.
+newtype TopMemoLine = TopMemoLine { unTopMemoLine :: Int }
+ deriving (Eq, Show)
+
+-- | The commodity and and the quantity may appear with the commodity
+-- on the left (e.g. USD 2.14) or with the commodity on the right
+-- (e.g. 2.14 USD).
+data Side
+ = CommodityOnLeft
+ | CommodityOnRight
+ deriving (Eq, Show, Ord)
+
+instance Ev.Equivalent Side where
+ equivalent = (==)
+ compareEv = compare
+
+-- | There may or may not be a space in between the commodity and the
+-- quantity.
+data SpaceBetween
+ = SpaceBetween
+ | NoSpaceBetween
+ deriving (Eq, Show, Ord)
+
+
+instance Ev.Equivalent SpaceBetween where
+ equivalent = (==)
+ compareEv = compare
+
+-- | The name of the file in which a transaction appears.
+newtype Filename = Filename { unFilename :: X.Text }
+ deriving (Eq, Show)
+
+-- | The line number on which a price appears.
+newtype PriceLine = PriceLine { unPriceLine :: Int }
+ deriving (Eq, Show)
+
+-- | The line number on which a posting appears.
+newtype PostingLine = PostingLine { unPostingLine :: Int }
+ deriving (Eq, Show)
+
+-- | All postings are numbered in order, beginning with the first
+-- posting in the first file and ending with the last posting
+-- in the last file.
+newtype GlobalPosting =
+ GlobalPosting { unGlobalPosting :: S.Serial }
+ deriving (Eq, Show)
+
+-- | The postings in each file are numbered in order.
+newtype FilePosting =
+ FilePosting { unFilePosting :: S.Serial }
+ deriving (Eq, Show)
+
+-- | All transactions are numbered in order, beginning with the first
+-- transaction in the first file and ending with the last transaction
+-- in the last file.
+newtype GlobalTransaction =
+ GlobalTransaction { unGlobalTransaction :: S.Serial }
+ deriving (Eq, Show)
+
+-- | The transactions in each file are numbered in order.
+newtype FileTransaction =
+ FileTransaction { unFileTransaction :: S.Serial }
+ deriving (Eq, Show)
+
diff --git a/lib/Penny/Lincoln/Bits/Price.hs b/lib/Penny/Lincoln/Bits/Price.hs
new file mode 100644
index 0000000..643e176
--- /dev/null
+++ b/lib/Penny/Lincoln/Bits/Price.hs
@@ -0,0 +1,52 @@
+module Penny.Lincoln.Bits.Price (
+ From ( From, unFrom )
+ , To ( To, unTo )
+ , CountPerUnit ( CountPerUnit, unCountPerUnit )
+ , Price ( from, to, countPerUnit )
+ , newPrice
+ ) where
+
+import Data.Monoid (mconcat)
+import qualified Penny.Lincoln.Equivalent as Ev
+import Penny.Lincoln.Equivalent ((==~))
+import qualified Penny.Lincoln.Bits.Open as O
+import Penny.Lincoln.Bits.Qty (QtyRep)
+
+
+newtype From = From { unFrom :: O.Commodity }
+ deriving (Eq, Ord, Show)
+
+newtype To = To { unTo :: O.Commodity }
+ deriving (Eq, Ord, Show)
+
+newtype CountPerUnit = CountPerUnit { unCountPerUnit :: QtyRep }
+ deriving (Eq, Ord, Show)
+
+instance Ev.Equivalent CountPerUnit where
+ equivalent (CountPerUnit x) (CountPerUnit y) = x ==~ y
+ compareEv (CountPerUnit x) (CountPerUnit y) = Ev.compareEv x y
+
+data Price = Price { from :: From
+ , to :: To
+ , countPerUnit :: CountPerUnit }
+ deriving (Eq, Ord, Show)
+
+-- | Two Price are equivalent if the From and To are equal and the
+-- CountPerUnit is equivalent.
+
+instance Ev.Equivalent Price where
+ equivalent (Price xf xt xc) (Price yf yt yc) =
+ xf == yf && xt == yt && xc ==~ yc
+
+ compareEv (Price xf xt xc) (Price yf yt yc) = mconcat
+ [ compare xf yf
+ , compare xt yt
+ , Ev.compareEv xc yc
+ ]
+
+-- | Succeeds only if From and To are different commodities.
+newPrice :: From -> To -> CountPerUnit -> Maybe Price
+newPrice f t cpu =
+ if unFrom f == unTo t
+ then Nothing
+ else Just $ Price f t cpu
diff --git a/lib/Penny/Lincoln/Bits/Qty.hs b/lib/Penny/Lincoln/Bits/Qty.hs
new file mode 100644
index 0000000..98e629f
--- /dev/null
+++ b/lib/Penny/Lincoln/Bits/Qty.hs
@@ -0,0 +1,794 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Penny quantities. A quantity is simply a count (possibly
+-- fractional) of something. It does not have a commodity or a
+-- Debit/Credit.
+module Penny.Lincoln.Bits.Qty
+ (
+ -- * Quantity representations
+ -- ** Components of quantity representations
+ Digit(..)
+ , DigitList(..)
+ , Digits(..)
+ , Grouper(..)
+ , PeriodGrp(..)
+ , CommaGrp(..)
+ , GroupedDigits(..)
+
+ , WholeFrac
+ , whole
+ , frac
+ , wholeFrac
+ , wholeOrFrac
+ , WholeOrFracResult
+ , wholeOrFracToQtyRep
+
+ , WholeOnly
+ , unWholeOnly
+ , wholeOnly
+
+ , WholeOrFrac(..)
+ , Radix(..)
+ , showRadix
+ , QtyRep(..)
+
+ -- ** Converting between quantity representations and quantities
+ , qtyToRep
+ , qtyToRepNoGrouping
+ , qtyToRepGrouped
+
+ -- ** Rendering quantity representations
+ , showQtyRep
+ , bestRadGroup
+
+ -- * Other stuff
+ , Qty
+ , HasQty(..)
+ , signif
+ , places
+ , compareQty
+ , newQty
+ , Signif
+ , Places
+ , add
+ , mult
+ , Difference(LeftBiggerBy, RightBiggerBy, Equal)
+ , difference
+ , allocate
+ , TotSeats
+ , PartyVotes
+ , SeatsWon
+ , largestRemainderMethod
+ , qtyOne
+ ) where
+
+-- # Imports
+
+import Control.Applicative ((<|>))
+import qualified Control.Monad.Exception.Synchronous as Ex
+import Data.Text (Text)
+import qualified Data.Text as X
+import Data.Ord(Down(..), comparing)
+import Data.List ( genericLength, genericReplicate, sortBy, group, sort,
+ genericSplitAt )
+import Data.List.Split (chunksOf)
+import Data.List.NonEmpty (NonEmpty((:|)), toList, nonEmpty)
+import qualified Data.List.NonEmpty as NE
+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
+import qualified Data.Semigroup(Semigroup(..))
+import Data.Semigroup(sconcat)
+import Data.Monoid ((<>))
+import qualified Penny.Lincoln.Equivalent as Ev
+import Penny.Lincoln.Equivalent (Equivalent(..))
+import qualified Penny.Steel.Sums as S
+
+data Digit = D0 | D1 | D2 | D3 | D4 | D5 | D6 | D7 | D8 | D9
+ deriving (Eq, Ord, Show, Enum, Bounded)
+
+-- | The digit grouping character when the radix is a period.
+data PeriodGrp
+ = PGSpace
+ -- ^ ASCII space
+ | PGThinSpace
+ -- ^ Unicode code point 0x2009
+ | PGComma
+ -- ^ Comma
+ deriving (Eq, Show, Ord, Enum, Bounded)
+
+-- | The digit grouping character when the radix is a comma.
+data CommaGrp
+ = CGSpace
+ -- ^ ASCII space
+ | CGThinSpace
+ -- ^ Unicode code point 0x2009
+ | CGPeriod
+ -- ^ Period
+ deriving (Eq, Show, Ord, Enum, Bounded)
+
+class Grouper a where
+ groupChar :: a -> Char
+
+instance Grouper PeriodGrp where
+ groupChar c = case c of
+ PGSpace -> ' '
+ PGThinSpace -> '\x2009'
+ PGComma -> ','
+
+instance Grouper CommaGrp where
+ groupChar c = case c of
+ CGSpace -> ' '
+ CGThinSpace -> '\x2009'
+ CGPeriod -> '.'
+
+newtype DigitList = DigitList { unDigitList :: NonEmpty Digit }
+ deriving (Eq, Show, Ord)
+
+instance Data.Semigroup.Semigroup DigitList where
+ (<>) (DigitList l1) (DigitList l2) =
+ DigitList $ l1 Data.Semigroup.<> l2
+
+class Digits a where
+ digits :: a -> DigitList
+
+instance Digits DigitList where
+ digits = id
+
+instance Digits (GroupedDigits a) where
+ digits (GroupedDigits d1 dr) = sconcat (d1 :| map snd dr)
+
+-- | All of the digits on a single side of a radix point. Typically
+-- this is parameterized on a type that represents the grouping
+-- character.
+data GroupedDigits a = GroupedDigits
+ { dsFirstPart :: DigitList
+ -- ^ The first chunk of digits
+ , dsNextParts :: [(a, DigitList)]
+ -- ^ Optional subsequent chunks of digits. Each is a grouping
+ -- character followed by additional digits.
+ } deriving (Eq, Show, Ord)
+
+
+-- | A quantity representation that has both a whole number and a
+-- fractional part. Abstract because there must be a non-zero digit in
+-- here somewhere, which 'wholeFrac' checks for. Typically this is
+-- parameterized on an instance of the Digits class, such as DigitList
+-- or GroupedDigits. This allows separate types for values that
+-- cannot be grouped as well as those that can.
+data WholeFrac a = WholeFrac
+ { whole :: a
+ , frac :: a
+ } deriving (Eq, Show, Ord)
+
+wholeFrac
+ :: Digits a
+ => a
+ -- ^ Whole part
+ -> a
+ -- ^ Fractional part
+ -> Maybe (WholeFrac a)
+ -- ^ If there is no non-zero digit present, Nothing. Otherwise,
+ -- returns the appropriate WholeFrac.
+wholeFrac w f = if digitsHasNonZero w || digitsHasNonZero f
+ then (Just (WholeFrac w f)) else Nothing
+
+digitsHasNonZero :: Digits a => a -> Bool
+digitsHasNonZero = any (/= D0) . toList . unDigitList . digits
+
+-- | A quantity representation that has a whole part only. Abstract
+-- because there must be a non-zero digit in here somewhere, which
+-- 'wholeOnly' checks for. Typically this is parameterized on an
+-- instance of the Digits class, such as DigitList or GroupedDigits.
+newtype WholeOnly a = WholeOnly { unWholeOnly :: a }
+ deriving (Eq, Show, Ord)
+
+wholeOnly :: Digits a => a -> Maybe (WholeOnly a)
+wholeOnly d = if digitsHasNonZero d then Just (WholeOnly d) else Nothing
+
+-- | Typically this is parameterized on an instance of the Digits
+-- class, such as DigitList or GroupedDigits.
+newtype WholeOrFrac a = WholeOrFrac
+ { unWholeOrFrac :: Either (WholeOnly a) (WholeFrac a) }
+ deriving (Eq, Show, Ord)
+
+wholeOrFrac
+ :: GroupedDigits a
+ -- ^ What's before the radix point
+
+ -> Maybe (GroupedDigits a)
+ -- ^ What's after the radix point (if anything)
+
+ -> Maybe (Either (WholeOrFrac DigitList)
+ (WholeOrFrac (GroupedDigits a)))
+wholeOrFrac g@(GroupedDigits l1 lr) mayAft = case mayAft of
+ Nothing -> case lr of
+ [] -> fmap (Left . WholeOrFrac . Left) $ wholeOnly l1
+ _ -> fmap (Right . WholeOrFrac . Left) $ wholeOnly g
+ Just aft@(GroupedDigits r1 rr) -> case (lr, rr) of
+ ([], []) -> fmap (Left . WholeOrFrac . Right) $ wholeFrac l1 r1
+ _ -> fmap (Right . WholeOrFrac . Right) $ wholeFrac g aft
+
+
+data Radix = Period | Comma
+ deriving (Eq, Show, Ord, Enum, Bounded)
+
+type WholeOrFracResult a = Either (WholeOrFrac DigitList)
+ (WholeOrFrac (GroupedDigits a))
+
+wholeOrFracToQtyRep
+ :: Either (WholeOrFracResult PeriodGrp) (WholeOrFracResult CommaGrp)
+ -> QtyRep
+wholeOrFracToQtyRep e = case e of
+ Left p -> case p of
+ Left dl -> QNoGrouping dl Period
+ Right gd -> QGrouped (Left gd)
+ Right c -> case c of
+ Left dl -> QNoGrouping dl Comma
+ Right gd -> QGrouped (Right gd)
+
+data QtyRep
+ = QNoGrouping (WholeOrFrac DigitList) Radix
+ | QGrouped (Either (WholeOrFrac (GroupedDigits PeriodGrp))
+ (WholeOrFrac (GroupedDigits CommaGrp)))
+ deriving (Eq, Show, Ord)
+
+instance Equivalent QtyRep where
+ equivalent x y = showQtyRep x == showQtyRep y
+ compareEv x y = Ev.compareEv (toQty x) (toQty y)
+
+-- | Converts an Integer to a list of digits.
+intToDigits :: Integer -> NonEmpty Digit
+intToDigits
+ = fmap intToDigit
+ . fromMaybe (error "intToDigits: show made empty list")
+ . nonEmpty
+ . show
+ where
+ intToDigit c = case c of
+ { '0' -> D0; '1' -> D1; '2' -> D2; '3' -> D3; '4' -> D4;
+ '5' -> D5; '6' -> D6; '7' -> D7; '8' -> D8; '9' -> D9;
+ _ -> error "intToDigits: show made non-digit character" }
+
+prependNonEmpty :: [a] -> NonEmpty a -> NonEmpty a
+prependNonEmpty [] x = x
+prependNonEmpty (x:xs) (y1 :| ys) = x :| (xs ++ (y1 : ys))
+
+qtyToRepNoGrouping :: Qty -> WholeOrFrac DigitList
+qtyToRepNoGrouping q =
+ let sig = intToDigits . signif $ q
+ e = places q
+ len = genericLength . toList $ sig
+ in WholeOrFrac $ if e == 0
+ then Left (WholeOnly (DigitList sig))
+ else if e < len
+ then let prefixLen = len - e
+ (pfx, sfx) = genericSplitAt prefixLen . toList $ sig
+ ne = fromMaybe
+ (error "qtyToRepNoGrouping: nonEmpty failed")
+ . NE.nonEmpty
+ (pfxNE, sfxNE) = (ne pfx, ne sfx)
+ (w, f) = (DigitList pfxNE, DigitList sfxNE)
+ in Right (WholeFrac w f)
+ else let leadZeroes = genericReplicate (e - len) D0
+ w = DigitList $ D0 :| []
+ f = DigitList $ prependNonEmpty leadZeroes sig
+ in Right (WholeFrac w f)
+
+
+
+-- | Given a list of QtyRep, determine the most common radix and
+-- grouping that are used. If a single QtyRep is grouped, then the
+-- result is also grouped. The most common grouping character
+-- determines which grouping character is used.
+--
+-- If no QtyRep are grouped, then the most common radix point is used
+-- and the result is not grouped.
+--
+-- If there is no radix point found, returns Nothing.
+bestRadGroup
+ :: [QtyRep]
+ -> Maybe (S.S3 Radix PeriodGrp CommaGrp)
+bestRadGroup ls = fromGrouping <|> fromRadix
+ where
+ grpToRadix q = case q of
+ QNoGrouping _ _ -> Nothing
+ QGrouped e -> Just $ either (const Period) (const Comma) e
+ mostCommonGrpRad = mode . mapMaybe grpToRadix $ ls
+ fromGrouping = do
+ rad <- mostCommonGrpRad
+ case rad of
+ Period -> fmap S.S3b . mostCommonPeriodGrp $ ls
+ Comma -> fmap S.S3c . mostCommonCommaGrp $ ls
+ fromRadix = fmap S.S3a . mode . mapMaybe noGrpToRadix $ ls
+ noGrpToRadix q = case q of
+ QNoGrouping _ r -> Just r
+ _ -> Nothing
+
+mostCommonPeriodGrp :: [QtyRep] -> Maybe PeriodGrp
+mostCommonPeriodGrp
+ = mode
+ . concatMap f
+ where
+ f q = case q of
+ QNoGrouping _ _ -> []
+ QGrouped e -> case e of
+ Left (WholeOrFrac ei) -> case ei of
+ Left _ -> []
+ Right (WholeFrac g1 g2) -> getSeps g1 ++ getSeps g2
+ Right _ -> []
+
+mostCommonCommaGrp :: [QtyRep] -> Maybe CommaGrp
+mostCommonCommaGrp
+ = mode
+ . concatMap f
+ where
+ f q = case q of
+ QNoGrouping _ _ -> []
+ QGrouped e -> case e of
+ Left _ -> []
+ Right (WholeOrFrac ei) -> case ei of
+ Left _ -> []
+ Right (WholeFrac g1 g2) -> getSeps g1 ++ getSeps g2
+
+getSeps :: GroupedDigits a -> [a]
+getSeps (GroupedDigits _ ls) = map fst ls
+
+
+mode :: Ord a => [a] -> Maybe a
+mode = listToMaybe . modes
+
+modes :: Ord a => [a] -> [a]
+modes
+ = map (head . snd)
+ . sortBy (comparing (Down . fst))
+ . map (\ls -> (length ls, ls))
+ . group
+ . sort
+
+-- | Groups digits, using the given split character.
+groupDigits
+ :: NonEmpty a
+ -> (NonEmpty a, [NonEmpty a])
+ -- ^ The first group of digits, and any subsequent groups.
+groupDigits
+ = toPair
+ . reverse
+ . map reverse
+ . chunksOf 3
+ . reverse
+ . toList
+ where
+ toPair [] = error "groupDigits: chunksOf produced empty list"
+ toPair (x:xs) = (ne x, map ne xs)
+ ne = fromMaybe (error $ "groupDigits: chunksOf produced"
+ ++ " empty inner list") . nonEmpty
+
+-- Digit grouping. Here are the rules.
+--
+-- No digits to the right of the decimal point are ever grouped. For
+-- now I will consider this a rare enough case that I will not bother
+-- with it.
+--
+-- Digits to the left of the decimal point are grouped as follows:
+--
+-- No grouping is performed unless the entire number (including the
+-- fractional portion) is at least five digits long. That means that
+-- 1234.5 is grouped into 1,234.5 but 1234 is not grouped.
+--
+-- Grouping is performed on the whole part only, and digits are
+-- grouped every third place.
+
+qtyToRepGrouped :: g -> Qty -> WholeOrFrac (GroupedDigits g)
+qtyToRepGrouped g q = WholeOrFrac
+ $ case unWholeOrFrac $ qtyToRepNoGrouping q of
+ Left (WholeOnly (DigitList ds)) ->
+ Left $ WholeOnly (mkWholeGroups ds)
+ Right (WholeFrac w f) ->
+ Right $ mkWholeFracGroups (unDigitList w) (unDigitList f)
+ where
+ mkGroups ds =
+ let (g1, gs) = groupDigits ds
+ mkGrp dl = (g, DigitList dl)
+ in GroupedDigits (DigitList g1) (map mkGrp gs)
+ mkWholeGroups ds = if (length . toList $ ds) > maxUngrouped
+ then mkGroups ds
+ else GroupedDigits (DigitList ds) []
+ mkWholeFracGroups w f = WholeFrac w' f'
+ where
+ f' = GroupedDigits (DigitList f) []
+ w' = if (length . toList $ w) + (length . toList $ f)
+ > maxUngrouped
+ then mkGroups w
+ else GroupedDigits (DigitList w) []
+ maxUngrouped = 4
+
+qtyToRep
+ :: S.S3 Radix PeriodGrp CommaGrp
+ -> Qty
+ -> QtyRep
+qtyToRep x q = case x of
+ S.S3a r -> QNoGrouping (qtyToRepNoGrouping q) r
+ S.S3b g -> QGrouped . Left $ qtyToRepGrouped g q
+ S.S3c g -> QGrouped . Right $ qtyToRepGrouped g q
+
+class HasQty a where
+ toQty :: a -> Qty
+
+
+
+digitToInt :: Digit -> Integer
+digitToInt d = case d of
+ { D0 -> 0; D1 -> 1; D2 -> 2; D3 -> 3; D4 -> 4; D5 -> 5;
+ D6 -> 6; D7 -> 7; D8 -> 8; D9 -> 9 }
+
+digitsToInt :: DigitList -> Integer
+digitsToInt
+ = sum
+ . map (\(e, s) -> s * 10 ^ e)
+ . zip ([0..] :: [Integer])
+ . map digitToInt
+ . reverse
+ . toList
+ . unDigitList
+
+instance HasQty QtyRep where
+ toQty q = case q of
+ QNoGrouping (WholeOrFrac ei) _ -> case ei of
+ Left (WholeOnly ds) -> Qty (digitsToInt ds) 0
+ Right (WholeFrac w f) -> Qty sig ex
+ where
+ sig = digitsToInt ((Data.Semigroup.<>) w f)
+ ex = genericLength . toList . unDigitList $ f
+ QGrouped ei -> either groupedToQty groupedToQty ei
+
+groupedToQty :: WholeOrFrac (GroupedDigits a) -> Qty
+groupedToQty (WholeOrFrac ei) = case ei of
+ Left (WholeOnly g) -> Qty (digitsToInt . digits $ g) 0
+ Right (WholeFrac w f) -> Qty sig ex
+ where
+ sig = digitsToInt ((Data.Semigroup.<>) (digits w) (digits f))
+ ex = genericLength . toList . unDigitList . digits $ f
+
+instance HasQty Qty where
+ toQty = id
+
+showDigit :: Digit -> Text
+showDigit d = case d of
+ { D0 -> "0"; D1 -> "1"; D2 -> "2"; D3 -> "3"; D4 -> "4";
+ D5 -> "5"; D6 -> "6"; D7 -> "7"; D8 -> "8"; D9 -> "9" }
+
+showRadix :: Radix -> Text
+showRadix r = case r of { Comma -> ","; Period -> "." }
+
+showDigitList :: DigitList -> X.Text
+showDigitList = X.concat . toList . fmap showDigit . unDigitList
+
+showGroupedDigits
+ :: Grouper a
+ => GroupedDigits a
+ -> Text
+showGroupedDigits (GroupedDigits d ds)
+ = showDigitList d <> (X.concat . map f $ ds)
+ where
+ f (c, cs) = (X.singleton $ groupChar c) <> showDigitList cs
+
+showWholeOnlyDigitList :: WholeOnly DigitList -> Text
+showWholeOnlyDigitList = showDigitList . unWholeOnly
+
+showWholeOnlyGroupedDigits
+ :: Grouper a
+ => WholeOnly (GroupedDigits a)
+ -> Text
+showWholeOnlyGroupedDigits = showGroupedDigits . unWholeOnly
+
+showWholeFracDigitList
+ :: Radix
+ -> WholeFrac DigitList
+ -> Text
+showWholeFracDigitList r wf
+ = showDigitList (whole wf) <> showRadix r <> showDigitList (frac wf)
+
+showWholeFracGroupedDigits
+ :: Grouper a
+ => Radix
+ -> WholeFrac (GroupedDigits a)
+ -> Text
+showWholeFracGroupedDigits r wf
+ = showGroupedDigits (whole wf) <> showRadix r
+ <> showGroupedDigits (frac wf)
+
+wholeOrFracGrouped
+ :: Grouper a
+ => Radix
+ -> WholeOrFrac (GroupedDigits a)
+ -> Text
+wholeOrFracGrouped r
+ = either showWholeOnlyGroupedDigits (showWholeFracGroupedDigits r)
+ . unWholeOrFrac
+
+wholeOrFracDigitList
+ :: Radix
+ -> WholeOrFrac DigitList
+ -> Text
+wholeOrFracDigitList r
+ = either showWholeOnlyDigitList (showWholeFracDigitList r)
+ . unWholeOrFrac
+
+
+showQtyRep :: QtyRep -> Text
+showQtyRep q = case q of
+ QNoGrouping wf r -> wholeOrFracDigitList r wf
+ QGrouped ei ->
+ either (wholeOrFracGrouped Period)
+ (wholeOrFracGrouped Comma) ei
+
+
+-- | A quantity is always greater than zero. Various odd questions
+-- happen if quantities can be zero. For instance, what if you have a
+-- debit whose quantity is zero? Does it require a balancing credit
+-- that is also zero? And how can you have a debit of zero anyway?
+--
+-- I can imagine situations where a quantity of zero might be useful;
+-- for instance maybe you want to specifically indicate that a
+-- particular posting in a transaction did not happen (for instance,
+-- that a paycheck deduction did not take place). I think the better
+-- way to handle that though would be through an addition to
+-- Debit\/Credit - maybe Debit\/Credit\/Zero. Barring the addition of
+-- that, though, the best way to indicate a situation such as this
+-- would be through transaction memos.
+--
+-- /WARNING/ - before doing comparisons or equality tests
+--
+-- The Eq instance is derived. Therefore q1 == q2 only if q1 and q2
+-- have both the same significand and the same exponent. You may instead
+-- want 'equivalent'. Similarly, the Ord instance is derived. It
+-- compares based on the integral value of the significand and of the
+-- exponent. You may instead want 'compareQty', which compares after
+-- equalizing the exponents.
+data Qty = Qty { signif :: !Integer
+ , places :: !Integer
+ } deriving (Eq, Show, Ord)
+
+instance Ev.Equivalent Qty where
+ equivalent x y = x' == y'
+ where
+ (x', y') = equalizeExponents x y
+ compareEv x y = compare x' y'
+ where
+ (x', y') = equalizeExponents x y
+
+type Signif = Integer
+type Places = Integer
+
+-- | Significand 1, exponent 0
+qtyOne :: Qty
+qtyOne = Qty 1 0
+
+
+newQty :: Signif -> Places -> Maybe Qty
+newQty m p
+ | m > 0 && p >= 0 = Just $ Qty m p
+ | otherwise = Nothing
+
+
+-- | Compares Qty after equalizing their exponents.
+--
+-- > compareQty (newQty 15 1) (newQty 1500 3) == EQ
+compareQty :: Qty -> Qty -> Ordering
+compareQty q1 q2 = compare (signif q1') (signif q2')
+ where
+ (q1', q2') = equalizeExponents q1 q2
+
+
+-- | Adjust the exponents on two Qty so they are equivalent
+-- before, but now have the same exponent.
+equalizeExponents :: Qty -> Qty -> (Qty, Qty)
+equalizeExponents x y = (x', y')
+ where
+ (ex, ey) = (places x, places y)
+ (x', y') = case compare ex ey of
+ GT -> (x, increaseExponent (ex - ey) y)
+ LT -> (increaseExponent (ey - ex) x, y)
+ EQ -> (x, y)
+
+-- | Increase the exponent by the amount given, so that the new Qty is
+-- equivalent to the old one. Takes the absolute value of the
+-- adjustment argument.
+increaseExponent :: Integer -> Qty -> Qty
+increaseExponent i (Qty m e) = Qty m' e'
+ where
+ amt = abs i
+ m' = m * 10 ^ amt
+ e' = e + amt
+
+-- | Increases the exponent to the given amount. Does nothing if the
+-- exponent is already at or higher than this amount.
+increaseExponentTo :: Integer -> Qty -> Qty
+increaseExponentTo i q@(Qty _ e) =
+ let diff = i - e
+ in if diff >= 0 then increaseExponent diff q else q
+
+data Difference =
+ LeftBiggerBy Qty
+ | RightBiggerBy Qty
+ | Equal
+ deriving (Eq, Show)
+
+-- | Subtract the second Qty from the first, after equalizing their
+-- exponents.
+difference :: Qty -> Qty -> Difference
+difference x y =
+ let (x', y') = equalizeExponents x y
+ (mx, my) = (signif x', signif y')
+ in case compare mx my of
+ GT -> LeftBiggerBy (Qty (mx - my) (places x'))
+ LT -> RightBiggerBy (Qty (my - mx) (places x'))
+ EQ -> Equal
+
+add :: Qty -> Qty -> Qty
+add x y =
+ let ((Qty xm e), (Qty ym _)) = equalizeExponents x y
+ in Qty (xm + ym) e
+
+
+
+mult :: Qty -> Qty -> Qty
+mult (Qty xm xe) (Qty ym ye) = Qty (xm * ym) (xe + ye)
+
+
+--
+-- Allocation
+--
+-- The steps of allocation:
+--
+-- Adjust all exponents, both on the amount to be allocated and on all
+-- the votes, so that the exponents are all equal.
+--
+-- Allocate the significands.
+--
+-- Return the quantities with the original exponents.
+
+-- | Allocate a Qty proportionally so that the sum of the results adds
+-- up to a given Qty. Fails if the allocation cannot be made (e.g. if
+-- it is impossible to allocate without overflowing Decimal.) The
+-- result will always add up to the given sum.
+allocate :: Qty -> (Qty, [Qty]) -> (Qty, [Qty])
+allocate tot (q1, qs) = case allocate' tot (q1:qs) of
+ [] -> error "allocate error"
+ x:xs -> (x, xs)
+
+allocate'
+ :: Qty
+ -- ^ The result will add up to this Qty.
+
+ -> [Qty]
+ -- ^ Allocate using these Qty (there must be at least one).
+
+ -> [Qty]
+ -- ^ The length of this list will be equal to the length of the list
+ -- of allocations. Each item will correspond to the original
+ -- allocation.
+
+allocate' tot ls =
+ let ((tot':ls'), e) = sameExponent (tot:ls)
+ (moreE, (_, ss)) =
+ multRemainderAllResultsAtLeast1 (signif tot')
+ (map signif ls')
+ totE = e + moreE
+ in map (\m -> Qty m totE) ss
+
+
+
+-- | Given a list of Decimals, and a single Decimal, return Decimals
+-- that are equivalent to the original Decimals, but where all
+-- Decimals have the same exponent. Also returns new exponent.
+sameExponent
+ :: [Qty]
+ -> ([Qty], Integer)
+sameExponent ls =
+ let newExp = maximum . fmap places $ ls
+ in (map (increaseExponentTo newExp) ls, newExp)
+
+
+
+
+
+type Multiplier = Integer
+
+multLargestRemainder
+ :: TotSeats
+ -> [PartyVotes]
+ -> Multiplier
+ -> (TotSeats, [SeatsWon])
+multLargestRemainder ts pv m =
+ let ts' = ts * 10 ^ m
+ pv' = map (\x -> x * 10 ^ m) pv
+ in (ts', largestRemainderMethod ts' pv')
+
+increasingMultRemainder
+ :: TotSeats
+ -> [PartyVotes]
+ -> [(Multiplier, (TotSeats, [SeatsWon]))]
+increasingMultRemainder ts pv =
+ zip [0..] (map (multLargestRemainder ts pv) [0..])
+
+multRemainderAllResultsAtLeast1
+ :: TotSeats
+ -> [PartyVotes]
+ -> (Multiplier, (TotSeats, [SeatsWon]))
+multRemainderAllResultsAtLeast1 ts pv
+ = head
+ . dropWhile (any (< 1) . snd . snd)
+ $ increasingMultRemainder ts pv
+
+-- Largest remainder method: votes for one party is divided by
+-- (total votes / number of seats). Result is an integer and a
+-- remainder. Each party gets the number of seats indicated by its
+-- integer. Parties are then ranked on the basis of the remainders, and
+-- those with the largest remainders get an additional seat until all
+-- seats have been distributed.
+type AutoSeats = Integer
+type PartyVotes = Integer
+type TotVotes = Integer
+type TotSeats = Integer
+type Remainder = Rational
+type SeatsWon = Integer
+
+-- | Allocates integers using the largest remainder method. This is
+-- the method used to allocate parliamentary seats in many countries,
+-- so the types are named accordingly.
+largestRemainderMethod
+ :: TotSeats
+ -- ^ Total number of seats in the legislature. This is the integer
+ -- that will be allocated. This number must be positive or this
+ -- function will fail at runtime.
+
+ -> [PartyVotes]
+ -- ^ The total seats will be allocated proportionally depending on
+ -- how many votes each party received. The sum of this list must be
+ -- positive, and each member of the list must be at least zero;
+ -- otherwise a runtime error will occur.
+
+ -> [SeatsWon]
+ -- ^ The sum of this list will always be equal to the total number
+ -- of seats, and its length will always be equal to length of the
+ -- PartyVotes list.
+
+largestRemainderMethod ts pvs =
+ let err s = error $ "largestRemainderMethod: error: " ++ s
+ in Ex.resolve err $ do
+ Ex.assert "TotalSeats not positive" (ts > 0)
+ Ex.assert "sum of [PartyVotes] not positive" (sum pvs > 0)
+ Ex.assert "negative member of [PartyVotes]" (minimum pvs >= 0)
+ return (allocRemainder ts . allocAuto ts $ pvs)
+
+
+autoAndRemainder
+ :: TotSeats -> TotVotes -> PartyVotes -> (AutoSeats, Remainder)
+autoAndRemainder ts tv pv =
+ let fI = fromIntegral :: Integer -> Rational
+ quota = if ts == 0
+ then error "autoAndRemainder: zero total seats"
+ else if tv == 0
+ then error "autoAndRemainder: zero total votes"
+ else fI tv / fI ts
+ in properFraction (fI pv / quota)
+
+
+allocAuto :: TotSeats -> [PartyVotes] -> [(AutoSeats, Remainder)]
+allocAuto ts pvs = map (autoAndRemainder ts (sum pvs)) pvs
+
+allocRemainder
+ :: TotSeats
+ -> [(AutoSeats, Remainder)]
+ -> [SeatsWon]
+allocRemainder ts ls =
+ let totLeft = ts - (sum . map fst $ ls)
+ (leftForEach, stillLeft) = totLeft `divMod` genericLength ls
+ wIndex = zip ([0..] :: [Integer]) ls
+ sorted = sortBy (comparing (snd . snd)) wIndex
+ wOrder = zip [0..] sorted
+ awarder (ord, (ix, (as, _))) =
+ if ord < stillLeft
+ then (ix, as + leftForEach + 1)
+ else (ix, as + leftForEach)
+ awarded = map awarder wOrder
+ in map snd . sortBy (comparing fst) $ awarded
diff --git a/lib/Penny/Lincoln/Builders.hs b/lib/Penny/Lincoln/Builders.hs
new file mode 100644
index 0000000..957f25a
--- /dev/null
+++ b/lib/Penny/Lincoln/Builders.hs
@@ -0,0 +1,28 @@
+-- | Partial functions that make common types in Lincoln. Some data
+-- types in Lincoln are deeply nested, with TextNonEmpty nested inside
+-- of a newtype, nested inside of a NonEmptyList, nested inside
+-- of... :) All the nesting ensures to the maximum extent possible
+-- that the type system reflects the restrictions that exist on
+-- Penny's data. For example, it would make no sense to have an empty
+-- account (that is, an account with no sub-accounts) or a sub-account
+-- whose name is an empty Text.
+--
+-- The disadvantage of the nesting is that building these data types
+-- can be tedious if, for example, you want to build some data within
+-- a short custom Haskell program. Thus, this module.
+
+module Penny.Lincoln.Builders
+ ( account
+ ) where
+
+import qualified Penny.Lincoln.Bits as B
+import qualified Data.Text as X
+
+-- | Create an Account. You supply a single Text, with colons to
+-- separate the different sub-accounts.
+account :: X.Text -> B.Account
+account s =
+ if X.null s
+ then B.Account []
+ else B.Account . map B.SubAccount . X.splitOn (X.singleton ':') $ s
+
diff --git a/lib/Penny/Lincoln/Ents.hs b/lib/Penny/Lincoln/Ents.hs
new file mode 100644
index 0000000..2d160a9
--- /dev/null
+++ b/lib/Penny/Lincoln/Ents.hs
@@ -0,0 +1,261 @@
+{-# LANGUAGE DeriveFunctor #-}
+
+-- | Containers for entries.
+--
+-- This module is the key guardian of the core principle of
+-- double-entry accounting, which is that debits and credits must
+-- always balance. An 'Ent' is a container for an 'Entry'. An 'Entry'
+-- holds a 'DrCr' and an 'Amount' which, in turn, holds a 'Commodity'
+-- and a 'Qty'. For a given 'Commodity' in a particular transaction,
+-- the sum of the debits must always be equal to the sum of the
+-- credits.
+--
+-- In addition to the 'Entry', the 'Ent' holds information about
+-- whether the particular 'Entry' it holds is inferred or not. An Ent
+-- is @inferred@ if the user did not supply the entry, but Penny was
+-- able to deduce its 'Entry' because proper entries were supplied for
+-- all the other postings in the transaction. The 'Ent' also holds
+-- arbitrary metadata--which will typically be other information about
+-- the particular posting, such as the payee, account, etc.
+--
+-- A collection of 'Ent' is an 'Ents'. This module will only create an
+-- 'Ent' as part of an 'Ents' (though you can later separate the 'Ent'
+-- from its other 'Ents' if you like.) In any given 'Ents', all of the
+-- 'Ent' collectively have a zero balance.
+--
+-- This module also contains type synonyms used to represent a
+-- Posting, which is an Ent bundled with its sibling Ents, and a
+-- Transaction.
+
+module Penny.Lincoln.Ents
+ ( -- * Ent
+ Ent
+ , entry
+ , meta
+ , inferred
+
+ -- * Ents
+ , Ents
+ , unEnts
+ , tupleEnts
+ , mapEnts
+ , traverseEnts
+ , ents
+ , rEnts
+ , headEnt
+ , tailEnts
+
+ -- * Postings and transactions
+ , Posting(..)
+ , Transaction(..)
+ , transactionToPostings
+ , views
+ , unrollSnd
+ ) where
+
+import Control.Applicative
+import Control.Arrow (second)
+import qualified Penny.Lincoln.Bits as B
+import qualified Penny.Lincoln.Balance as Bal
+import Control.Monad (guard)
+import qualified Penny.Lincoln.Equivalent as Ev
+import Penny.Lincoln.Equivalent ((==~))
+import Data.Monoid (mconcat, (<>))
+import Data.List (foldl', unfoldr, sortBy)
+import Data.Maybe (catMaybes)
+import qualified Data.Traversable as Tr
+import qualified Data.Foldable as Fdbl
+
+
+-- | Information about an entry, along with whether it is inferred and
+-- its metadata.
+data Ent m = Ent
+ { entry :: Either (B.Entry B.QtyRep) (B.Entry B.Qty)
+ -- ^ The entry from an Ent. If the Ent is inferred--that is, if the
+ -- user did not supply an entry for it and Penny was able to infer
+ -- the entry--this will be a Right with the inferred Entry.
+
+ , meta :: m
+ -- ^ The metadata accompanying an Ent
+
+ , inferred :: Bool
+ -- ^ True if the entry was inferred.
+ } deriving (Eq, Ord, Show)
+
+-- | Two Ents are equivalent if the entries are equivalent and the
+-- metadata is equivalent (whether the Ent is inferred or not is
+-- ignored.)
+instance Ev.Equivalent m => Ev.Equivalent (Ent m) where
+ equivalent (Ent e1 m1 _) (Ent e2 m2 _) = e1 ==~ e2 && m1 ==~ m2
+
+ compareEv (Ent e1 m1 _) (Ent e2 m2 _) =
+ Ev.compareEv e1 e2 <> Ev.compareEv m1 m2
+
+instance Functor Ent where
+ fmap f (Ent e m i) = Ent e (f m) i
+
+newtype Ents m = Ents { unEnts :: [Ent m] }
+ deriving (Eq, Ord, Show, Functor)
+
+-- | Ents are equivalent if the content Ents of each are
+-- equivalent. The order of the ents is insignificant.
+instance Ev.Equivalent m => Ev.Equivalent (Ents m) where
+ equivalent (Ents e1) (Ents e2) =
+ let (e1', e2') = (sortBy Ev.compareEv e1, sortBy Ev.compareEv e2)
+ in and $ (length e1 == length e2)
+ : zipWith Ev.equivalent e1' e2'
+
+ compareEv (Ents e1) (Ents e2) =
+ let (e1', e2') = (sortBy Ev.compareEv e1, sortBy Ev.compareEv e2)
+ in mconcat $ compare (length e1) (length e2)
+ : zipWith Ev.compareEv e1' e2'
+
+instance Fdbl.Foldable Ents where
+ foldr f z (Ents ls) = case ls of
+ [] -> z
+ x:xs -> f (meta x) (Fdbl.foldr f z (map meta xs))
+
+instance Tr.Traversable Ents where
+ sequenceA = fmap Ents . Tr.sequenceA . map seqEnt . unEnts
+
+-- | Alter the metadata Ents, while examining the Ents themselves. If
+-- you only want to change the metadata and you don't need to examine
+-- the other contents of the Ent, use the Functor instance. You cannot
+-- change non-metadata aspects of the Ent.
+mapEnts :: (Ent a -> b) -> Ents a -> Ents b
+mapEnts f = Ents . map f' . unEnts where
+ f' e = e { meta = f e }
+
+-- | Alter the metadata of Ents while examing their contents. If you
+-- do not need to examine their contents, use the Traversable
+-- instance.
+traverseEnts :: Applicative f => (Ent a -> f b) -> Ents a -> f (Ents b)
+traverseEnts f = fmap Ents . Tr.traverse f' . unEnts where
+ f' en@(Ent e _ i) = Ent <$> pure e <*> f en <*> pure i
+
+seqEnt :: Applicative f => Ent (f a) -> f (Ent a)
+seqEnt (Ent e m i) = Ent <$> pure e <*> m <*> pure i
+
+-- | Every Ents alwas contains at least two ents, and possibly
+-- additional ones.
+tupleEnts :: Ents m -> (Ent m, Ent m, [Ent m])
+tupleEnts (Ents ls) = case ls of
+ t1:t2:ts -> (t1, t2, ts)
+ _ -> error "tupleEnts: ents does not have two ents"
+
+-- | In a Posting, the Ent at the front of the list of Ents is the
+-- main posting. There are additional postings. This function
+-- rearranges the Ents multiple times so that each posting is at the
+-- head of the list exactly once.
+views :: Ents m -> [Ents m]
+views = map Ents . orderedPermute . unEnts
+
+-- | > unrollSnd (undefined, []) == []
+-- > unrollSnd (1, [1,2,3]) = [(1,1), (1,2), (1,3)]
+
+unrollSnd :: (a, [b]) -> [(a, b)]
+unrollSnd = unfoldr f where
+ f (_, []) = Nothing
+ f (a, b:bs) = Just ((a, b), (a, bs))
+
+-- | Splits a Transaction into Postings.
+transactionToPostings :: Transaction -> [Posting]
+transactionToPostings =
+ map Posting . unrollSnd . second views . unTransaction
+
+-- | Get information from the head posting in the View, which is the
+-- one you are most likely interested in. This never fails, as every
+-- Ents has at least two postings.
+headEnt :: Ents m -> Ent m
+headEnt (Ents ls) = case ls of
+ [] -> error "ents: empty view"
+ x:_ -> x
+
+-- | Get information on sibling Ents.
+tailEnts :: Ents m -> (Ent m, [Ent m])
+tailEnts (Ents ls) = case ls of
+ [] -> error "ents: tailEnts: empty view"
+ _:xs -> case xs of
+ [] -> error "ents: tailEnts: only one sibling"
+ s2:ss -> (s2, ss)
+
+-- | A Transaction and a Posting are identical on the inside, but they
+-- have different semantic meanings so they are wrapped in newtypes.
+newtype Transaction = Transaction
+ { unTransaction :: ( B.TopLineData, Ents B.PostingData ) }
+ deriving (Eq, Show)
+
+-- | In a Posting, the Ent yielded by 'headEnt' will be the posting of
+-- interest. The other sibling postings are also available for
+-- inspection.
+newtype Posting = Posting
+ { unPosting :: ( B.TopLineData, Ents B.PostingData ) }
+ deriving (Eq, Show)
+
+-- | Returns a list of lists where each element in the original list
+-- is in the front of a new list once.
+--
+-- > orderedPermute [1,2,3] == [[1,2,3], [2,3,1], [3,1,2]]
+orderedPermute :: [a] -> [[a]]
+orderedPermute ls = take (length ls) (iterate toTheBack ls)
+ where
+ toTheBack [] = []
+ toTheBack (a:as) = as ++ [a]
+
+-- | Creates an 'Ents'. At most, one of the Maybe Entry can be Nothing
+-- and this function will infer the remaining Entry. This function
+-- fails if it cannot create a balanced Ents.
+ents
+ :: [(Maybe (Either (B.Entry B.QtyRep) (B.Entry B.Qty)), m)]
+ -> Maybe (Ents m)
+ents ls = do
+ guard . not . null $ ls
+ let nNoEntries = length . filter (== Nothing) . map fst $ ls
+ case Bal.entriesToBalanced
+ . map (either (fmap B.toQty) id)
+ . catMaybes
+ . map fst
+ $ ls of
+ Bal.NotInferable -> Nothing
+ Bal.Inferable e -> do
+ guard $ nNoEntries == 1
+ let makeEnt (mayEn, mt) = case mayEn of
+ Nothing -> Ent (Right e) mt True
+ Just en -> Ent en mt False
+ return . Ents $ map makeEnt ls
+ Bal.Balanced ->
+ let makeEnt (mayEn, mt) = case mayEn of
+ Nothing -> Nothing
+ Just en -> Just $ Ent en mt False
+ in fmap Ents $ mapM makeEnt ls
+
+
+-- | Creates 'Ents'. Unlike 'ents' this function never fails because
+-- you are restricted in the inputs that you can give it. It will
+-- always infer the last Entry. All Entries except one will have the
+-- same DrCr; the last, inferred one will have the opposite DrCr.
+rEnts
+ :: B.Commodity
+ -- ^ Commodity for all postings
+ -> B.DrCr
+ -- ^ DrCr for all non-inferred postings
+ -> (Either B.QtyRep B.Qty, m)
+ -- ^ Non-inferred posting 1
+ -> [(Either B.QtyRep B.Qty, m)]
+ -- ^ Remaining non-inferred postings
+ -> m
+ -- ^ Metadata for inferred posting
+ -> Ents m
+rEnts com dc (q1, m1) nonInfs lastMeta =
+ let tot = foldl' B.add (either B.toQty id q1)
+ . map (either B.toQty id . fst) $ nonInfs
+ p1 = makePstg (q1, m1)
+ ps = map makePstg nonInfs
+ makeEntry = either (\q -> Left (B.Entry dc (B.Amount q com)))
+ (\q -> Right (B.Entry dc (B.Amount q com)))
+ makePstg (q, m) = Ent (makeEntry q) m False
+ lastPstg = Ent (Right (B.Entry (B.opposite dc)
+ (B.Amount tot com))) lastMeta True
+ in Ents $ p1:ps ++ [lastPstg]
+
+
diff --git a/lib/Penny/Lincoln/Equivalent.hs b/lib/Penny/Lincoln/Equivalent.hs
new file mode 100644
index 0000000..e111971
--- /dev/null
+++ b/lib/Penny/Lincoln/Equivalent.hs
@@ -0,0 +1,50 @@
+module Penny.Lincoln.Equivalent where
+
+import Data.Monoid ((<>))
+
+-- | Comparisons for equivalency. Two items are equivalent if they
+-- have the same semantic meaning, even if the data in the two items
+-- is different.
+class Equivalent a where
+ equivalent :: a -> a -> Bool
+
+ -- | Compares based on equivalency.
+ compareEv :: a -> a -> Ordering
+
+(==~) :: Equivalent a => a -> a -> Bool
+(==~) = equivalent
+infix 4 ==~
+
+instance Equivalent a => Equivalent (Maybe a) where
+ equivalent a b = case (a, b) of
+ (Just x, Just y) -> x ==~ y
+ (Nothing, Nothing) -> True
+ _ -> False
+ compareEv a b = case (a, b) of
+ (Just x, Just y) -> compareEv x y
+ (Nothing, Nothing) -> EQ
+ (Just _, Nothing) -> GT
+ (Nothing, Just _) -> LT
+
+instance (Equivalent a, Equivalent b) => Equivalent (a, b) where
+ equivalent (a1, b1) (a2, b2) = a1 ==~ a2 && b1 ==~ b2
+ compareEv (a1, b1) (a2, b2) =
+ compareEv a1 a2 <> compareEv b1 b2
+
+instance (Equivalent a, Equivalent b, Equivalent c) =>
+ Equivalent (a, b, c) where
+ equivalent (a1, b1, c1) (a2, b2, c2) = a1 ==~ a2
+ && b1 ==~ b2 && c1 ==~ c2
+ compareEv (a1, b1, c1) (a2, b2, c2) =
+ compareEv a1 a2 <> compareEv b1 b2 <> compareEv c1 c2
+
+instance (Equivalent a, Equivalent b) => Equivalent (Either a b) where
+ equivalent e1 e2 = case (e1, e2) of
+ (Left l1, Left l2) -> l1 ==~ l2
+ (Right r1, Right r2) -> r1 ==~ r2
+ _ -> False
+ compareEv e1 e2 = case (e1, e2) of
+ (Left l1, Left l2) -> compareEv l1 l2
+ (Right l1, Right l2) -> compareEv l1 l2
+ (Left _, Right _) -> LT
+ (Right _, Left _) -> GT
diff --git a/lib/Penny/Lincoln/HasText.hs b/lib/Penny/Lincoln/HasText.hs
new file mode 100644
index 0000000..0412b62
--- /dev/null
+++ b/lib/Penny/Lincoln/HasText.hs
@@ -0,0 +1,58 @@
+module Penny.Lincoln.HasText where
+
+import Data.Text (Text)
+import qualified Data.Text as X
+
+import qualified Penny.Lincoln.Bits as B
+
+class HasText a where
+ text :: a -> Text
+
+instance HasText Text where
+ text = id
+
+instance HasText B.SubAccount where
+ text = B.unSubAccount
+
+instance HasText B.Flag where
+ text = B.unFlag
+
+instance HasText B.Commodity where
+ text = B.unCommodity
+
+instance HasText B.Number where
+ text = B.unNumber
+
+instance HasText B.Payee where
+ text = B.unPayee
+
+instance HasText B.Tag where
+ text = B.unTag
+
+instance HasText B.Filename where
+ text = B.unFilename
+
+class HasTextList a where
+ textList :: a -> [Text]
+
+-- | Wraps instances of HasTextList and provides a delimiter; the
+-- result is an instance of HasText.
+data Delimited a = Delimited
+ { delimiter :: Text
+ , delimited :: a
+ } deriving (Eq, Show)
+
+instance HasTextList a => HasTextList (Delimited a) where
+ textList = textList . delimited
+
+instance HasTextList a => HasText (Delimited a) where
+ text a = X.intercalate (delimiter a) . textList . delimited $ a
+
+instance HasTextList B.Account where
+ textList = map text . B.unAccount
+
+instance HasTextList B.Tags where
+ textList = map text . B.unTags
+
+instance HasTextList B.Memo where
+ textList = B.unMemo
diff --git a/lib/Penny/Lincoln/Matchers.hs b/lib/Penny/Lincoln/Matchers.hs
new file mode 100644
index 0000000..7cc0fff
--- /dev/null
+++ b/lib/Penny/Lincoln/Matchers.hs
@@ -0,0 +1,21 @@
+-- | Type synonyms for functions dealing with text matching.
+
+module Penny.Lincoln.Matchers where
+
+import qualified Data.Text as X
+import qualified Control.Monad.Exception.Synchronous as Ex
+import qualified Text.Matchers as MT
+
+-- | A function that makes Matchers.
+type Factory
+ = MT.CaseSensitive
+ -- ^ Will this matcher be case sensitive?
+
+ -> X.Text
+ -- ^ The pattern to use when testing for a match. For example, this
+ -- might be a regular expression, or simply the text to be matched.
+
+ -> Ex.Exceptional X.Text MT.Matcher
+ -- ^ Sometimes producing a matcher might fail; for example, the user
+ -- might have supplied a bad pattern. If so, an exception is
+ -- returned. On success, a Matcher is returned.
diff --git a/lib/Penny/Lincoln/Predicates.hs b/lib/Penny/Lincoln/Predicates.hs
new file mode 100644
index 0000000..82c8c94
--- /dev/null
+++ b/lib/Penny/Lincoln/Predicates.hs
@@ -0,0 +1,323 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Functions that return a boolean based upon some criterion that
+-- matches something, often a PostFam. Useful when filtering
+-- Postings.
+module Penny.Lincoln.Predicates
+ ( LPdct
+ , MakePdct
+ , payee
+ , number
+ , flag
+ , postingMemo
+ , transactionMemo
+ , date
+ , qty
+ , drCr
+ , debit
+ , credit
+ , commodity
+ , account
+ , accountLevel
+ , accountAny
+ , tag
+ , reconciled
+ , filename
+
+ -- * Serials
+ , serialPdct
+ , MakeSerialPdct
+ , fwdGlobalPosting
+ , backGlobalPosting
+ , fwdFilePosting
+ , backFilePosting
+ , fwdGlobalTransaction
+ , backGlobalTransaction
+ , fwdFileTransaction
+ , backFileTransaction
+ ) where
+
+
+import Data.List (intersperse)
+import Data.Maybe (fromMaybe)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as X
+import qualified Data.Time as Time
+import qualified Penny.Lincoln.Bits as B
+import Penny.Lincoln.HasText (HasText, text, HasTextList, textList)
+import qualified Penny.Lincoln.Queries as Q
+import Penny.Lincoln.Ents (Posting)
+import qualified Penny.Lincoln.Ents as E
+import qualified Text.Matchers as M
+import qualified Data.Prednote.Pdct as P
+import Penny.Lincoln.Serial (forward, backward)
+
+type LPdct = P.Pdct Posting
+
+type MakePdct = M.Matcher -> LPdct
+
+-- * Matching helpers
+match
+ :: HasText a
+ => Text
+ -- ^ Description of this field
+ -> (Posting -> a)
+ -- ^ Function that returns the field being matched
+ -> M.Matcher
+ -> LPdct
+match t f m = P.operand desc pd
+ where
+ desc = makeDesc t m
+ pd = M.match m . text . f
+
+matchMaybe
+ :: HasText a
+ => Text
+ -- ^ Description of this field
+ -> (Posting -> Maybe a)
+ -> M.Matcher
+ -> LPdct
+matchMaybe t f m = P.operand desc pd
+ where
+ desc = makeDesc t m
+ pd = maybe False (M.match m . text) . f
+
+makeDesc :: Text -> M.Matcher -> Text
+makeDesc t m
+ = "subject: " <> t
+ <> " matcher: " <> M.matchDesc m
+
+-- | Does the given matcher match any of the elements of the Texts in
+-- a HasTextList?
+matchAny
+ :: HasTextList a
+ => Text
+ -> (Posting -> a)
+ -> M.Matcher
+ -> LPdct
+matchAny t f m = P.operand desc pd
+ where
+ desc = makeDesc t m
+ pd = any (M.match m) . textList . f
+
+-- | Does the given matcher match the text that is at the given
+-- element of a HasTextList? If the HasTextList does not have a
+-- sufficent number of elements to perform this test, returns False.
+matchLevel
+ :: HasTextList a
+ => Int
+ -> Text
+ -> (Posting -> a)
+ -> M.Matcher
+ -> LPdct
+matchLevel l d f m = P.operand desc pd
+ where
+ desc = makeDesc ("level " <> X.pack (show l) <> " of " <> d) m
+ pd pf = let ts = textList (f pf)
+ in if l < 0 || l >= length ts
+ then False
+ else M.match m (ts !! l)
+
+-- | Does the matcher match the text of the memo? Joins each line of
+-- the memo with a space.
+matchMemo
+ :: Text
+ -> (Posting -> Maybe B.Memo)
+ -> M.Matcher
+ -> LPdct
+matchMemo t f m = P.operand desc pd
+ where
+ desc = makeDesc t m
+ pd = maybe False doMatch . f
+ doMatch = M.match m
+ . X.intercalate (X.singleton ' ')
+ . B.unMemo
+
+matchDelimited
+ :: HasTextList a
+ => Text
+ -- ^ Separator
+ -> Text
+ -- ^ Label
+ -> (Posting -> a)
+ -> M.Matcher
+ -> LPdct
+matchDelimited sep lbl f m = match lbl f' m
+ where
+ f' = X.concat . intersperse sep . textList . f
+
+-- * Pattern matching fields
+
+payee :: MakePdct
+payee = matchMaybe "payee" Q.payee
+
+number :: MakePdct
+number = matchMaybe "number" Q.number
+
+flag :: MakePdct
+flag = matchMaybe "flag" Q.flag
+
+postingMemo :: MakePdct
+postingMemo = matchMemo "posting memo" Q.postingMemo
+
+transactionMemo :: MakePdct
+transactionMemo = matchMemo "transaction memo" Q.transactionMemo
+
+-- * Date
+
+date
+ :: Ordering
+ -> Time.UTCTime
+ -> LPdct
+date ord u = P.compareBy (X.pack . show $ u)
+ "UTC date and time"
+ (\l -> compare (B.toUTC . Q.dateTime $ l) u) ord
+
+
+qty :: Ordering -> B.Qty -> LPdct
+qty o q = P.compareBy (X.pack . show $ q) "quantity"
+ (\l -> B.compareQty (Q.qty l) q) o
+
+
+drCr :: B.DrCr -> LPdct
+drCr dc = P.operand desc pd
+ where
+ desc = "entry is a " <> s
+ s = case dc of { B.Debit -> "debit"; B.Credit -> "credit" }
+ pd pf = Q.drCr pf == dc
+
+debit :: LPdct
+debit = drCr B.Debit
+
+credit :: LPdct
+credit = drCr B.Credit
+
+commodity :: M.Matcher -> LPdct
+commodity = match "commodity" Q.commodity
+
+account :: M.Matcher -> LPdct
+account = matchDelimited ":" "account" Q.account
+
+accountLevel :: Int -> M.Matcher -> LPdct
+accountLevel i = matchLevel i "account" Q.account
+
+accountAny :: M.Matcher -> LPdct
+accountAny = matchAny "any sub-account" Q.account
+
+tag :: M.Matcher -> LPdct
+tag = matchAny "any tag" Q.tags
+
+-- | True if a posting is reconciled; that is, its flag is exactly
+-- @R@.
+reconciled :: LPdct
+reconciled = P.operand d p
+ where
+ d = "posting flag is exactly \"R\" (is reconciled)"
+ p = maybe False ((== X.singleton 'R') . B.unFlag) . Q.flag
+
+filename :: M.Matcher -> LPdct
+filename = matchMaybe "filename" Q.filename
+
+-- | Makes Pdct based on comparisons against a particular serial.
+
+serialPdct
+ :: Text
+ -- ^ Name of the serial, e.g. @globalPosting@
+
+ -> (a -> Maybe Int)
+ -- ^ How to obtain the serial from the item being examined
+
+ -> Int
+ -- ^ The right hand side
+
+ -> Ordering
+ -- ^ 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.operand n f
+ where
+ n = "serial " <> name <> " is " <> descCmp <> " "
+ <> X.pack (show i)
+ descCmp = case o of
+ EQ -> "equal to"
+ LT -> "less than"
+ GT -> "greater than"
+ f = fromMaybe False . fmap (\ser -> compare ser i == o)
+ . getSer
+
+type MakeSerialPdct = Int -> Ordering -> P.Pdct Posting
+
+fwdGlobalPosting :: MakeSerialPdct
+fwdGlobalPosting =
+ serialPdct "fwdGlobalPosting"
+ $ fmap (forward . B.unGlobalPosting)
+ . B.pdGlobal
+ . E.meta
+ . E.headEnt
+ . snd
+ . E.unPosting
+
+backGlobalPosting :: MakeSerialPdct
+backGlobalPosting =
+ serialPdct "revGlobalPosting"
+ $ fmap (backward . B.unGlobalPosting)
+ . B.pdGlobal
+ . E.meta
+ . E.headEnt
+ . snd
+ . E.unPosting
+
+fwdFilePosting :: MakeSerialPdct
+fwdFilePosting
+ = serialPdct "fwdFilePosting"
+ $ fmap (forward . B.unFilePosting . B.pFilePosting)
+ . B.pdFileMeta
+ . E.meta
+ . E.headEnt
+ . snd
+ . E.unPosting
+
+backFilePosting :: MakeSerialPdct
+backFilePosting
+ = serialPdct "revFilePosting"
+ $ fmap (backward . B.unFilePosting . B.pFilePosting)
+ . B.pdFileMeta
+ . E.meta
+ . E.headEnt
+ . snd
+ . E.unPosting
+
+fwdGlobalTransaction :: MakeSerialPdct
+fwdGlobalTransaction
+ = serialPdct "fwdGlobalTransaction"
+ $ fmap (forward . B.unGlobalTransaction)
+ . B.tlGlobal
+ . fst
+ . E.unPosting
+
+backGlobalTransaction :: MakeSerialPdct
+backGlobalTransaction
+ = serialPdct "backGlobalTransaction"
+ $ fmap (backward . B.unGlobalTransaction)
+ . B.tlGlobal
+ . fst
+ . E.unPosting
+
+fwdFileTransaction :: MakeSerialPdct
+fwdFileTransaction
+ = serialPdct "fwdFileTransaction"
+ $ fmap (forward . B.unFileTransaction . B.tFileTransaction)
+ . B.tlFileMeta
+ . fst
+ . E.unPosting
+
+backFileTransaction :: MakeSerialPdct
+backFileTransaction
+ = serialPdct "backFileTransaction"
+ $ fmap (backward . B.unFileTransaction . B.tFileTransaction)
+ . B.tlFileMeta
+ . fst
+ . E.unPosting
diff --git a/lib/Penny/Lincoln/Predicates/Siblings.hs b/lib/Penny/Lincoln/Predicates/Siblings.hs
new file mode 100644
index 0000000..d6c76e6
--- /dev/null
+++ b/lib/Penny/Lincoln/Predicates/Siblings.hs
@@ -0,0 +1,327 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Functions that return a boolean based upon some criterion that
+-- matches something, often a PostFam. Useful when filtering
+-- Postings.
+module Penny.Lincoln.Predicates.Siblings
+ ( LPdct
+ , MakePdct
+ , payee
+ , number
+ , flag
+ , postingMemo
+ , qty
+ , parseQty
+ , drCr
+ , debit
+ , credit
+ , commodity
+ , account
+ , accountLevel
+ , accountAny
+ , tag
+ , reconciled
+
+ -- * Serials
+ , serialPdct
+ , MakeSerialPdct
+ , fwdGlobalPosting
+ , backGlobalPosting
+ , fwdFilePosting
+ , backFilePosting
+ , fwdGlobalTransaction
+ , backGlobalTransaction
+ , fwdFileTransaction
+ , backFileTransaction
+ ) where
+
+
+import Control.Arrow (second)
+import Data.List (intersperse)
+import Data.Maybe (catMaybes)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as X
+import qualified Penny.Lincoln.Bits as B
+import qualified Penny.Lincoln.Ents as E
+import Penny.Lincoln.Serial (forward, backward)
+import Penny.Lincoln.HasText (HasText, text, HasTextList, textList)
+import qualified Penny.Lincoln.Queries.Siblings as Q
+import Penny.Lincoln.Ents (Posting)
+import qualified Text.Matchers as M
+import qualified Data.Prednote.Pdct as P
+
+type LPdct = P.Pdct Posting
+
+type MakePdct = M.Matcher -> LPdct
+
+-- * Matching helpers
+match
+ :: HasText a
+ => Text
+ -- ^ Description of this field
+ -> (Posting -> [a])
+ -- ^ Function that returns the field being matched
+ -> M.Matcher
+ -> LPdct
+match t f m = P.operand desc pd
+ where
+ desc = makeDesc t m
+ pd = any (M.match m) . map text . f
+
+matchMaybe
+ :: HasText a
+ => Text
+ -- ^ Description of this field
+ -> (Posting -> [Maybe a])
+ -> M.Matcher
+ -> LPdct
+matchMaybe t f m = P.operand desc pd
+ where
+ desc = makeDesc t m
+ pd = any (== (Just True))
+ . map (fmap (M.match m . text))
+ . f
+
+makeDesc :: Text -> M.Matcher -> Text
+makeDesc t m
+ = "subject: " <> t <> " (any sibling posting) matcher: "
+ <> M.matchDesc m
+
+-- | Does the given matcher match any of the elements of the Texts in
+-- a HasTextList?
+matchAny
+ :: HasTextList a
+ => Text
+ -> (Posting -> [a])
+ -> M.Matcher
+ -> LPdct
+matchAny t f m = P.operand desc pd
+ where
+ desc = makeDesc t m
+ pd = any (any (M.match m)) . map textList . f
+
+-- | Does the given matcher match the text that is at the given
+-- element of a HasTextList? If the HasTextList does not have a
+-- sufficent number of elements to perform this test, returns False.
+matchLevel
+ :: HasTextList a
+ => Int
+ -> Text
+ -> (Posting -> [a])
+ -> M.Matcher
+ -> LPdct
+matchLevel l d f m = P.operand desc pd
+ where
+ desc = makeDesc ("level " <> X.pack (show l) <> " of " <> d) m
+ pd pf = let doMatch list = if l < 0 || l >= length list
+ then False
+ else M.match m (list !! l)
+ in any doMatch . map textList . f $ pf
+
+-- | Does the matcher match the text of the memo? Joins each line of
+-- the memo with a space.
+matchMemo
+ :: Text
+ -> (Posting -> [Maybe B.Memo])
+ -> M.Matcher
+ -> LPdct
+matchMemo t f m = P.operand desc pd
+ where
+ desc = makeDesc t m
+ pd = any (maybe False doMatch) . f
+ doMatch = M.match m
+ . X.intercalate (X.singleton ' ')
+ . B.unMemo
+
+matchDelimited
+ :: HasTextList a
+ => Text
+ -- ^ Separator
+ -> Text
+ -- ^ Label
+ -> (Posting -> [a])
+ -> M.Matcher
+ -> LPdct
+matchDelimited sep lbl f m = match lbl f' m
+ where
+ f' = map (X.concat . intersperse sep . textList) . f
+
+-- * Pattern matching fields
+
+payee :: MakePdct
+payee = matchMaybe "payee" Q.payee
+
+number :: MakePdct
+number = matchMaybe "number" Q.number
+
+flag :: MakePdct
+flag = matchMaybe "flag" Q.flag
+
+postingMemo :: MakePdct
+postingMemo = matchMemo "posting memo" Q.postingMemo
+
+-- | A Pdct that returns True if @compare subject qty@ returns the
+-- given Ordering.
+qty :: Ordering -> B.Qty -> LPdct
+qty o q = P.operand desc pd
+ where
+ desc = "quantity of any sibling is " <> dd <> " " <> X.pack (show q)
+ dd = case o of
+ LT -> "less than"
+ GT -> "greater than"
+ EQ -> "equal to"
+ pd = any ((== o) . (`compare` q)) . Q.qty
+
+parseQty
+ :: X.Text
+ -> Maybe (B.Qty -> LPdct)
+parseQty x
+ | x == "==" = Just (qty EQ)
+ | x == "=" = Just (qty EQ)
+ | x == ">" = Just (qty GT)
+ | x == "<" = Just (qty LT)
+ | x == "/=" = Just (\q -> P.not (qty EQ q))
+ | x == "!=" = Just (\q -> P.not (qty EQ q))
+ | x == ">=" = Just (\q -> P.or [qty GT q, qty EQ q])
+ | x == "<=" = Just (\q -> P.or [qty LT q, qty EQ q])
+ | otherwise = Nothing
+
+drCr :: B.DrCr -> LPdct
+drCr dc = P.operand desc pd
+ where
+ desc = "entry of any sibling is a " <> s
+ s = case dc of { B.Debit -> "debit"; B.Credit -> "credit" }
+ pd = any (== dc) . Q.drCr
+
+debit :: LPdct
+debit = drCr B.Debit
+
+credit :: LPdct
+credit = drCr B.Credit
+
+commodity :: M.Matcher -> LPdct
+commodity = match "commodity" Q.commodity
+
+account :: M.Matcher -> LPdct
+account = matchDelimited ":" "account" Q.account
+
+accountLevel :: Int -> M.Matcher -> LPdct
+accountLevel i = matchLevel i "account" Q.account
+
+accountAny :: M.Matcher -> LPdct
+accountAny = matchAny "any sub-account" Q.account
+
+tag :: M.Matcher -> LPdct
+tag = matchAny "any tag" Q.tags
+
+-- | True if a posting is reconciled; that is, its flag is exactly
+-- @R@.
+reconciled :: LPdct
+reconciled = P.operand d p
+ where
+ d = "posting flag is exactly \"R\" (is reconciled)"
+ p = any (maybe False ((== X.singleton 'R') . B.unFlag))
+ . Q.flag
+
+--
+-- Serials
+--
+
+-- | Makes Pdct based on comparisons against a particular serial.
+
+serialPdct
+ :: Text
+ -- ^ Name of the serial, e.g. @globalPosting@
+
+ -> ((B.TopLineData, E.Ent B.PostingData) -> Maybe Int)
+ -- ^ How to obtain the serial from the item being examined
+
+ -> Int
+ -- ^ 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.
+
+ -> P.Pdct E.Posting
+
+serialPdct name getSer i o = P.operand n f
+ where
+ n = "serial " <> name <> " is " <> descCmp <> " "
+ <> X.pack (show i)
+ descCmp = case o of
+ EQ -> "equal to"
+ LT -> "less than"
+ GT -> "greater than"
+ f = any (\ser -> compare ser i == o )
+ . catMaybes
+ . map getSer
+ . E.unrollSnd
+ . second (\(x, xs) -> (x:xs))
+ . second E.tailEnts
+ . E.unPosting
+
+type MakeSerialPdct = Int -> Ordering -> P.Pdct Posting
+
+fwdGlobalPosting :: MakeSerialPdct
+fwdGlobalPosting =
+ serialPdct "fwdGlobalPosting"
+ $ fmap (forward . B.unGlobalPosting)
+ . B.pdGlobal
+ . E.meta
+ . snd
+
+backGlobalPosting :: MakeSerialPdct
+backGlobalPosting =
+ serialPdct "revGlobalPosting"
+ $ fmap (backward . B.unGlobalPosting)
+ . B.pdGlobal
+ . E.meta
+ . snd
+
+fwdFilePosting :: MakeSerialPdct
+fwdFilePosting
+ = serialPdct "fwdFilePosting"
+ $ fmap (forward . B.unFilePosting . B.pFilePosting)
+ . B.pdFileMeta
+ . E.meta
+ . snd
+
+backFilePosting :: MakeSerialPdct
+backFilePosting
+ = serialPdct "revFilePosting"
+ $ fmap (backward . B.unFilePosting . B.pFilePosting)
+ . B.pdFileMeta
+ . E.meta
+ . snd
+
+fwdGlobalTransaction :: MakeSerialPdct
+fwdGlobalTransaction
+ = serialPdct "fwdGlobalTransaction"
+ $ fmap (forward . B.unGlobalTransaction)
+ . B.tlGlobal
+ . fst
+
+backGlobalTransaction :: MakeSerialPdct
+backGlobalTransaction
+ = serialPdct "backGlobalTransaction"
+ $ fmap (backward . B.unGlobalTransaction)
+ . B.tlGlobal
+ . fst
+
+fwdFileTransaction :: MakeSerialPdct
+fwdFileTransaction
+ = serialPdct "fwdFileTransaction"
+ $ fmap (forward . B.unFileTransaction . B.tFileTransaction)
+ . B.tlFileMeta
+ . fst
+
+backFileTransaction :: MakeSerialPdct
+backFileTransaction
+ = serialPdct "backFileTransaction"
+ $ fmap (backward . B.unFileTransaction . B.tFileTransaction)
+ . B.tlFileMeta
+ . fst
diff --git a/lib/Penny/Lincoln/PriceDb.hs b/lib/Penny/Lincoln/PriceDb.hs
new file mode 100644
index 0000000..f32a3c8
--- /dev/null
+++ b/lib/Penny/Lincoln/PriceDb.hs
@@ -0,0 +1,99 @@
+-- | A database of price information. A PricePoint has a DateTime, a
+-- From commodity, a To commodity, and a QtyPerUnit. The PriceDb holds
+-- this information for several prices. You can query the database by
+-- supplying a from commodity, a to commodity, and a DateTime, and the
+-- database will give you the QtyPerUnit, if there is one.
+module Penny.Lincoln.PriceDb (
+ PriceDb,
+ emptyDb,
+ addPrice,
+ getPrice,
+ PriceDbError(FromNotFound, ToNotFound, CpuNotFound),
+ convertAsOf
+ ) where
+
+import qualified Control.Monad.Exception.Synchronous as Ex
+import qualified Data.Map as M
+import qualified Data.Time as T
+import qualified Penny.Lincoln.Bits as B
+
+type CpuMap = M.Map T.UTCTime B.CountPerUnit
+type ToMap = M.Map B.To CpuMap
+
+-- | The PriceDb holds information about prices. Create an empty one
+-- using 'emptyDb' then fill it with values using foldl or similar.
+newtype PriceDb = PriceDb (M.Map B.From ToMap)
+
+-- | An empty PriceDb
+emptyDb :: PriceDb
+emptyDb = PriceDb M.empty
+
+-- | Add a single price to the PriceDb.
+addPrice :: PriceDb -> B.PricePoint -> PriceDb
+addPrice (PriceDb db) (B.PricePoint dt pr _ _ _) = PriceDb m'
+ where
+ m' = M.alter f (B.from pr) db
+ utc = B.toUTC dt
+ cpu = B.countPerUnit pr
+ f k = case k of
+ Nothing -> Just $ M.singleton (B.to pr) cpuMap
+ where
+ cpuMap = M.singleton utc cpu
+ Just tm -> Just tm'
+ where
+ tm' = M.alter g (B.to pr) tm
+ g maybeTo = case maybeTo of
+ Nothing -> Just $ M.singleton utc cpu
+ Just cpuMap -> Just $ M.insert utc cpu cpuMap
+
+
+
+-- | Getting prices can fail; if it fails, an Error is returned.
+data PriceDbError = FromNotFound | ToNotFound | CpuNotFound
+
+-- | Looks up values from the PriceDb. Throws "Error" if something
+-- fails.
+--
+-- The DateTime is the time at which to find a price. If a price
+-- exists for that exact DateTime, that price is returned. If no price
+-- exists for that exact DateTime, but there is a price for an earlier
+-- DateTime, the latest possible price is returned. If there are no
+-- earlier prices, CpuNotFound is thrown.
+
+getPrice ::
+ PriceDb
+ -> B.From
+ -> B.To
+ -> B.DateTime
+ -> Ex.Exceptional PriceDbError B.CountPerUnit
+getPrice (PriceDb db) fr to dt = do
+ let utc = B.toUTC dt
+ toMap <- Ex.fromMaybe FromNotFound $ M.lookup fr db
+ cpuMap <- Ex.fromMaybe ToNotFound $ M.lookup to toMap
+ let (lower, exact, _) = M.splitLookup utc cpuMap
+ case exact of
+ Just c -> return c
+ Nothing ->
+ if M.null lower
+ then Ex.throw CpuNotFound
+ else return . snd . M.findMax $ lower
+
+
+-- | Given an Amount and a Commodity to convert the amount to,
+-- converts the Amount to the given commodity. If the Amount given is
+-- already in the To commodity, simply returns what was passed in. Can
+-- fail and throw PriceDbError. Internally uses 'getPrice', so read its
+-- documentation for details on how price lookup works.
+convertAsOf ::
+ B.HasQty q
+ => PriceDb
+ -> B.DateTime
+ -> B.To
+ -> B.Amount q
+ -> Ex.Exceptional PriceDbError B.Qty
+convertAsOf db dt to (B.Amount qt fr)
+ | fr == B.unTo to = return . B.toQty $ qt
+ | otherwise = do
+ cpu <- fmap B.unCountPerUnit (getPrice db (B.From fr) to dt)
+ let qt' = B.mult (B.toQty cpu) (B.toQty qt)
+ return qt'
diff --git a/lib/Penny/Lincoln/Queries.hs b/lib/Penny/Lincoln/Queries.hs
new file mode 100644
index 0000000..96881e2
--- /dev/null
+++ b/lib/Penny/Lincoln/Queries.hs
@@ -0,0 +1,108 @@
+-- | Examining a Posting for a particular component of the main
+-- posting (as opposed to the sibling postings) in the Posting. For
+-- some components, such as the payee, the posting might have one
+-- piece of data while the TopLine has something else. These functions
+-- will examine the Posting first and, if it has no information, use
+-- the data from the TopLine if it is there.
+module Penny.Lincoln.Queries where
+
+import qualified Penny.Lincoln.Bits as B
+import qualified Penny.Lincoln.Ents as E
+import Penny.Lincoln.Balance (Balance, entryToBalance)
+import qualified Data.Time as Time
+
+-- | Uses the data from the Posting if it is set; otherwise, use the
+-- data from the TopLine.
+best
+ :: (B.TopLineData -> Maybe a)
+ -> (E.Ents B.PostingData -> Maybe a)
+ -> E.Posting
+ -> Maybe a
+best fp ft vp = case fp . fst . E.unPosting $ vp of
+ Nothing -> ft . snd . E.unPosting $ vp
+ Just r -> Just r
+
+payee :: E.Posting -> Maybe B.Payee
+payee = best (B.tPayee . B.tlCore)
+ (B.pPayee . B.pdCore . E.meta . E.headEnt)
+
+number :: E.Posting -> Maybe B.Number
+number = best (B.tNumber . B.tlCore)
+ (B.pNumber . B.pdCore . E.meta . E.headEnt)
+
+flag :: E.Posting -> Maybe B.Flag
+flag = best (B.tFlag . B.tlCore)
+ (B.pFlag . B.pdCore . E.meta . E.headEnt)
+
+postingMemo :: E.Posting -> Maybe B.Memo
+postingMemo = B.pMemo . B.pdCore . E.meta . E.headEnt . snd . E.unPosting
+
+transactionMemo :: E.Posting -> Maybe B.Memo
+transactionMemo = B.tMemo . B.tlCore . fst . E.unPosting
+
+dateTime :: E.Posting -> B.DateTime
+dateTime = B.tDateTime . B.tlCore . fst . E.unPosting
+
+localDay :: E.Posting -> Time.Day
+localDay = B.day . dateTime
+
+account :: E.Posting -> B.Account
+account = B.pAccount . B.pdCore . E.meta . E.headEnt . snd . E.unPosting
+
+tags :: E.Posting -> B.Tags
+tags = B.pTags . B.pdCore . E.meta . E.headEnt . snd . E.unPosting
+
+entry :: E.Posting -> Either (B.Entry B.QtyRep) (B.Entry B.Qty)
+entry = E.entry . E.headEnt . snd . E.unPosting
+
+balance :: E.Posting -> Balance
+balance = either entryToBalance entryToBalance . entry
+
+drCr :: E.Posting -> B.DrCr
+drCr = either B.drCr B.drCr . entry
+
+amount :: E.Posting -> Either (B.Amount B.QtyRep) (B.Amount B.Qty)
+amount = either (Left . B.amount) (Right . B.amount) . entry
+
+eiQty :: E.Posting -> Either B.QtyRep B.Qty
+eiQty = either (Left . B.qty) (Right . B.qty) . amount
+
+-- | Every Posting either has a Qty or it can be computed from its QtyRep.
+qty :: E.Posting -> B.Qty
+qty = either B.toQty B.toQty . eiQty
+
+commodity :: E.Posting -> B.Commodity
+commodity = either B.commodity B.commodity . amount
+
+topMemoLine :: E.Posting -> Maybe B.TopMemoLine
+topMemoLine p = (B.tlFileMeta . fst . E.unPosting $ p) >>= B.tTopMemoLine
+
+topLineLine :: E.Posting -> Maybe B.TopLineLine
+topLineLine = fmap B.tTopLineLine . B.tlFileMeta . fst . E.unPosting
+
+globalTransaction :: E.Posting -> Maybe B.GlobalTransaction
+globalTransaction = B.tlGlobal . fst . E.unPosting
+
+fileTransaction :: E.Posting -> Maybe B.FileTransaction
+fileTransaction = fmap B.tFileTransaction . B.tlFileMeta . fst . E.unPosting
+
+globalPosting :: E.Posting -> Maybe B.GlobalPosting
+globalPosting = B.pdGlobal . E.meta . E.headEnt . snd . E.unPosting
+
+filePosting :: E.Posting -> Maybe B.FilePosting
+filePosting = fmap B.pFilePosting . B.pdFileMeta . E.meta
+ . E.headEnt . snd . E.unPosting
+
+postingLine :: E.Posting -> Maybe B.PostingLine
+postingLine = fmap B.pPostingLine . B.pdFileMeta
+ . E.meta . E.headEnt . snd . E.unPosting
+
+side :: E.Posting -> Maybe B.Side
+side = B.pSide . B.pdCore . E.meta . E.headEnt . snd . E.unPosting
+
+spaceBetween :: E.Posting -> Maybe B.SpaceBetween
+spaceBetween = B.pSpaceBetween . B.pdCore
+ . E.meta . E.headEnt . snd . E.unPosting
+
+filename :: E.Posting -> Maybe B.Filename
+filename = fmap B.tFilename . B.tlFileMeta . fst . E.unPosting
diff --git a/lib/Penny/Lincoln/Queries/Siblings.hs b/lib/Penny/Lincoln/Queries/Siblings.hs
new file mode 100644
index 0000000..cb961d8
--- /dev/null
+++ b/lib/Penny/Lincoln/Queries/Siblings.hs
@@ -0,0 +1,102 @@
+-- | Like 'Penny.Lincoln.Queries' but instead of querying the main
+-- posting of the PostFam, queries the siblings. Therefore, these
+-- functions return a list, with each entry in the list containing the
+-- best answer for each sibling. There is one item in the list for
+-- each sibling, even if all these items contain the same data (for
+-- instance, a posting might have five siblings, but all five siblings
+-- might have the same payee. Nonetheless the 'payee' function will
+-- return a list of five items.)
+module Penny.Lincoln.Queries.Siblings where
+
+import Control.Arrow (second, first)
+import qualified Penny.Lincoln.Bits as B
+import qualified Penny.Lincoln.Ents as E
+import Penny.Lincoln.Balance (Balance, entryToBalance)
+
+-- | For all siblings, uses information from the Posting if it is set;
+-- otherwise, uses data from the TopLine.
+bestSibs
+ :: (B.PostingCore -> Maybe a)
+ -> (B.TopLineCore -> Maybe a)
+ -> E.Posting
+ -> [Maybe a]
+bestSibs fp ft =
+ map f
+ . map (second (B.pdCore . E.meta))
+ . E.unrollSnd
+ . second (\(x, xs) -> (x:xs))
+ . second E.tailEnts
+ . first B.tlCore
+ . E.unPosting
+ where
+ f (tl, vw) = maybe (ft tl) Just (fp vw)
+
+
+-- | For all siblings, get the information from the Posting if it
+-- exists; otherwise Nothing.
+sibs
+ :: (E.Ent B.PostingData -> a)
+ -> E.Posting
+ -> [a]
+sibs fp = map fp . snd . fmap ((\(x, xs) -> (x:xs)) . E.tailEnts)
+ . E.unPosting
+
+payee :: E.Posting -> [Maybe B.Payee]
+payee = bestSibs B.pPayee B.tPayee
+
+number :: E.Posting -> [Maybe B.Number]
+number = bestSibs B.pNumber B.tNumber
+
+flag :: E.Posting -> [Maybe B.Flag]
+flag = bestSibs B.pFlag B.tFlag
+
+postingMemo :: E.Posting -> [Maybe B.Memo]
+postingMemo = sibs (B.pMemo . B.pdCore . E.meta)
+
+account :: E.Posting -> [B.Account]
+account = sibs (B.pAccount . B.pdCore . E.meta)
+
+tags :: E.Posting -> [B.Tags]
+tags = sibs (B.pTags . B.pdCore . E.meta)
+
+entry :: E.Posting -> [Either (B.Entry B.QtyRep) (B.Entry B.Qty)]
+entry = sibs E.entry
+
+balance :: E.Posting -> [Balance]
+balance = map (either entryToBalance entryToBalance) . entry
+
+drCr :: E.Posting -> [B.DrCr]
+drCr = map (either B.drCr B.drCr) . entry
+
+amount :: E.Posting -> [Either (B.Amount B.QtyRep) (B.Amount B.Qty)]
+amount = map (either (Left . B.amount) (Right . B.amount)) . entry
+
+qty :: E.Posting -> [B.Qty]
+qty = map (either (B.toQty . B.qty) (B.toQty . B.qty)) . amount
+
+commodity :: E.Posting -> [B.Commodity]
+commodity = map (either B.commodity B.commodity) . amount
+
+postingLine :: E.Posting -> [Maybe B.PostingLine]
+postingLine = sibs (fmap B.pPostingLine . B.pdFileMeta . E.meta)
+
+side :: E.Posting -> [Maybe B.Side]
+side = sibs (B.pSide . B.pdCore . E.meta)
+
+spaceBetween :: E.Posting -> [Maybe B.SpaceBetween]
+spaceBetween = sibs (B.pSpaceBetween . B.pdCore . E.meta)
+
+globalPosting :: E.Posting -> [Maybe B.GlobalPosting]
+globalPosting = sibs (B.pdGlobal . E.meta)
+
+filePosting :: E.Posting -> [Maybe B.FilePosting]
+filePosting = sibs (fmap B.pFilePosting . B.pdFileMeta . E.meta)
+
+globalTransaction :: E.Posting -> [Maybe B.GlobalTransaction]
+globalTransaction =
+ map B.tlGlobal
+ . map fst
+ . E.unrollSnd
+ . second (\(x, xs) -> (x:xs))
+ . second E.tailEnts
+ . E.unPosting
diff --git a/lib/Penny/Lincoln/Serial.hs b/lib/Penny/Lincoln/Serial.hs
new file mode 100644
index 0000000..3fb6507
--- /dev/null
+++ b/lib/Penny/Lincoln/Serial.hs
@@ -0,0 +1,126 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Penny.Lincoln.Serial (
+ Serial, forward, backward, serialItems, serialSomeItems,
+ serialNestedItems) where
+
+import Control.Applicative (Applicative, (<*>), pure, (*>))
+import Control.Monad (ap, liftM, replicateM_)
+import Data.Traversable (Traversable)
+import qualified Data.Traversable as Tr
+import qualified Data.Foldable as Fdbl
+import GHC.Generics (Generic)
+import Data.Binary (Binary)
+
+data SerialSt = SerialSt
+ { nextFwd :: Int
+ , nextBack :: Int
+ } deriving Show
+
+
+data Serial = Serial
+ { forward :: Int
+ , backward :: Int
+ } deriving (Eq, Show, Ord, Generic)
+
+instance Binary Serial
+
+newtype GenSerial a = GenSerial (SerialSt -> (a, SerialSt))
+
+instance Functor GenSerial where
+ fmap = liftM
+
+instance Applicative GenSerial where
+ pure = return
+ (<*>) = ap
+
+instance Monad GenSerial where
+ return a = GenSerial $ \s -> (a, s)
+ (GenSerial k) >>= f = GenSerial $ \s ->
+ let (a, s') = k s
+ GenSerial g = f a
+ in g s'
+
+incrementBack :: GenSerial ()
+incrementBack = GenSerial $ \s ->
+ let s' = SerialSt (nextFwd s) (nextBack s + 1)
+ in ((), s')
+
+getSerial :: GenSerial Serial
+getSerial = GenSerial $ \s ->
+ let s' = SerialSt (nextFwd s + 1) (nextBack s - 1)
+ in (Serial (nextFwd s) (nextBack s), s')
+
+makeSerials :: GenSerial a -> a
+makeSerials (GenSerial k) =
+ let (r, _) = k (SerialSt 0 0) in r
+
+serialItems :: (Serial -> a -> b) -> [a] -> [b]
+serialItems f as = zipWith f (nSerials (length as)) as
+
+nSerials :: Int -> [Serial]
+nSerials n =
+ makeSerials $
+ (sequence . replicate n $ incrementBack)
+ *> (sequence . replicate n $ getSerial)
+
+serialSomeItems
+ :: (a -> Either b (Serial -> b))
+ -> [a]
+ -> [b]
+serialSomeItems f as = makeSerials k
+ where
+ k = do
+ let doIncr i = case f i of
+ Left _ -> return ()
+ Right _ -> incrementBack
+ mapM_ doIncr as
+ let addSer i = case f i of
+ Left b -> return b
+ Right add -> getSerial >>= return . add
+ mapM addSer as
+
+-- | Adds serials to items that are nested within other items.
+serialNestedItems
+ :: Traversable f
+ => (a -> Either b ((f c), (Serial -> c -> d), (f d -> b)))
+ -- ^ When applied to each item, this function returns Left if the
+ -- item does not need a serial, or Right if it has items that need
+ -- serials. In the Right is the container with items that need
+ -- serials, the function that applies serials to each item, and a
+ -- function to re-wrap the container with the serialed items.
+
+ -> [a]
+ -> [b]
+serialNestedItems getEi as = makeSerials k
+ where
+ k = do
+ serialNestedIncrBack getEi as
+ mapM (serialNestedAddSerials getEi) as
+
+-- | Increments the back serial by the needed number of items.
+serialNestedIncrBack
+ :: Fdbl.Foldable f
+ => (a -> Either b (f c, x, y))
+ -> [a]
+ -> GenSerial ()
+serialNestedIncrBack f = mapM_ doIncr where
+ doIncr i = case f i of
+ Left _ -> return ()
+ Right (ctnr, _, _) ->
+ let len = length . Fdbl.toList $ ctnr
+ in replicateM_ len incrementBack
+
+-- | Assigns serials to nested items.
+serialNestedAddSerials
+ :: Tr.Traversable f
+ => (a -> Either b (f c, (Serial -> c -> d), f d -> b))
+ -> a
+ -> GenSerial b
+serialNestedAddSerials f a = case f a of
+ Left b -> return b
+ Right (ctnr, addSer, rewrap) -> do
+ let adder i = do
+ s <- getSerial
+ return $ addSer s i
+ fmap rewrap $ Tr.mapM adder ctnr
diff --git a/lib/Penny/Shield.hs b/lib/Penny/Shield.hs
new file mode 100644
index 0000000..c8ae464
--- /dev/null
+++ b/lib/Penny/Shield.hs
@@ -0,0 +1,106 @@
+-- | Shield - the Penny runtime environment
+--
+-- Both Cabin and Copper can benefit from knowing information about
+-- the Penny runtime environment, such as environment variables and
+-- whether standard output is a terminal. That information is provided
+-- by the Runtime type. In the future this module may also provide
+-- information about the POSIX locale configuration. For now, that
+-- information would require reaching into the FFI and so it is not
+-- implemented.
+
+module Penny.Shield (
+ ScreenLines,
+ unScreenLines,
+ ScreenWidth,
+ unScreenWidth,
+ Output(IsTTY, NotTTY),
+ Runtime,
+ environment,
+ currentTime,
+ output,
+ screenLines,
+ screenWidth,
+ Term,
+ term,
+ runtime,
+ termFromEnv,
+ autoTerm)
+ where
+
+import Control.Applicative ((<$>), (<*>))
+import qualified Data.Time as T
+import System.Environment (getEnvironment)
+import System.IO (hIsTerminalDevice, stdout)
+import qualified System.Console.Rainbow as C
+
+import qualified Penny.Lincoln.Bits as B
+
+data ScreenLines = ScreenLines { unScreenLines :: Int }
+ deriving Show
+
+newtype ScreenWidth = ScreenWidth { unScreenWidth :: Int }
+ deriving Show
+
+data Output = IsTTY | NotTTY deriving (Eq, Ord, Show)
+
+newtype Term = Term { unTerm :: String } deriving Show
+
+-- | Information about the runtime environment.
+data Runtime = Runtime { environment :: [(String, String)]
+ , currentTime :: B.DateTime
+ , output :: Output }
+
+runtime :: IO Runtime
+runtime = Runtime
+ <$> getEnvironment
+ <*> (toDT <$> T.getZonedTime)
+ <*> findOutput
+ where
+ toDT t = case B.fromZonedTime t of
+ Nothing -> error "time conversion error"
+ Just ti -> ti
+
+findOutput :: IO Output
+findOutput = do
+ isTerm <- hIsTerminalDevice stdout
+ return $ if isTerm then IsTTY else NotTTY
+
+screenLines :: Runtime -> Maybe ScreenLines
+screenLines r =
+ (lookup "LINES" . environment $ r)
+ >>= safeRead
+ >>= return . ScreenLines
+
+screenWidth :: Runtime -> Maybe ScreenWidth
+screenWidth r =
+ (lookup "COLUMNS" . environment $ r)
+ >>= safeRead
+ >>= return . ScreenWidth
+
+term :: Runtime -> Maybe Term
+term r =
+ (lookup "TERM" . environment $ r)
+ >>= return . Term
+
+-- | Read, but without crashes.
+safeRead :: (Read a) => String -> Maybe a
+safeRead s = case reads s of
+ (a, []):[] -> Just a
+ _ -> Nothing
+
+-- | Determines which Chunk Term to use based on the TERM environment
+-- variable, regardless of whether standard output is a terminal. Uses
+-- Dumb if TERM is not set.
+termFromEnv :: Runtime -> C.Term
+termFromEnv rt = case term rt of
+ Just t -> C.TermName . unTerm $ t
+ Nothing -> C.Dumb
+
+-- | Determines which Chunk Term to use based on whether standard
+-- output is a terminal. Uses Dumb if standard output is not a
+-- terminal; otherwise, uses the TERM environment variable.
+autoTerm :: Runtime -> C.Term
+autoTerm rt = case output rt of
+ IsTTY -> termFromEnv rt
+ NotTTY -> C.Dumb
+
diff --git a/lib/Penny/Steel.hs b/lib/Penny/Steel.hs
new file mode 100644
index 0000000..153a01b
--- /dev/null
+++ b/lib/Penny/Steel.hs
@@ -0,0 +1,3 @@
+-- | Steel - independent Penny utilities
+
+module Penny.Steel where
diff --git a/lib/Penny/Steel/NestedMap.hs b/lib/Penny/Steel/NestedMap.hs
new file mode 100644
index 0000000..d3bde09
--- /dev/null
+++ b/lib/Penny/Steel/NestedMap.hs
@@ -0,0 +1,275 @@
+-- | 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/lib/Penny/Steel/Sums.hs b/lib/Penny/Steel/Sums.hs
new file mode 100644
index 0000000..b2af8bd
--- /dev/null
+++ b/lib/Penny/Steel/Sums.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+-- | Anonymous sum types.
+
+module Penny.Steel.Sums where
+
+import Data.Binary (Binary)
+import GHC.Generics (Generic)
+
+data S3 a b c
+ = S3a a
+ | S3b b
+ | S3c c
+ deriving (Eq, Ord, Show, Generic)
+
+instance (Binary a, Binary b, Binary c) => Binary (S3 a b c)
+
+data S4 a b c d
+ = S4a a
+ | S4b b
+ | S4c c
+ | S4d d
+ deriving (Eq, Ord, Show, Generic)
+
+instance (Binary a, Binary b, Binary c, Binary d) => Binary (S4 a b c d)
+
+partitionS3 :: [S3 a b c] -> ([a], [b], [c])
+partitionS3 = foldr f ([], [], [])
+ where
+ f i (as, bs, cs) = case i of
+ S3a a -> (a:as, bs, cs)
+ S3b b -> (as, b:bs, cs)
+ S3c c -> (as, bs, c:cs)
+
+partitionS4 :: [S4 a b c d] -> ([a], [b], [c], [d])
+partitionS4 = foldr f ([], [], [], [])
+ where
+ f i (as, bs, cs, ds) = case i of
+ S4a a -> (a:as, bs, cs, ds)
+ S4b b -> (as, b:bs, cs, ds)
+ S4c c -> (as, bs, c:cs, ds)
+ S4d d -> (as, bs, cs, d:ds)
+
+caseS3 :: (a -> d) -> (b -> d) -> (c -> d) -> S3 a b c -> d
+caseS3 fa fb fc s3 = case s3 of
+ S3a a -> fa a
+ S3b b -> fb b
+ S3c c -> fc c
+
+caseS4 :: (a -> e) -> (b -> e) -> (c -> e) -> (d -> e) -> S4 a b c d -> e
+caseS4 fa fb fc fd s4 = case s4 of
+ S4a a -> fa a
+ S4b b -> fb b
+ S4c c -> fc c
+ S4d d -> fd d
+
+mapS3 :: (a -> a1) -> (b -> b1) -> (c -> c1) -> S3 a b c -> S3 a1 b1 c1
+mapS3 fa fb fc = caseS3 (S3a . fa) (S3b . fb) (S3c . fc)
+
+mapS4
+ :: (a -> a1) -> (b -> b1) -> (c -> c1) -> (d -> d1)
+ -> S4 a b c d
+ -> S4 a1 b1 c1 d1
+mapS4 a b c d = caseS4 (S4a . a) (S4b . b) (S4c . c) (S4d . d)
+
+mapS3a
+ :: Functor f
+ => (a -> f a1) -> (b -> f b1) -> (c -> f c1) -> S3 a b c -> f (S3 a1 b1 c1)
+mapS3a a b c = caseS3 (fmap S3a . a) (fmap S3b . b) (fmap S3c . c)
+
+mapS4a
+