diff --git a/lib/Penny.hs b/lib/Penny.hs
--- a/lib/Penny.hs
+++ b/lib/Penny.hs
@@ -23,9 +23,6 @@
-- ** Expression type
, Exp.ExprDesc(..)
- -- ** Formatting quantities
- , defaultQtyFormat
-
-- ** Convert report options
, Target(..)
, CP.SortBy(..)
@@ -35,9 +32,15 @@
, Spacers(..)
, widthFromRuntime
, Ps.yearMonthDay
- , Ps.qtyAsIs
- , Ps.balanceAsIs
+ -- ** Formatting quantities
+ , S3(..)
+ , qtyFormatter
+ , getQtyFormat
+ , L.Radix(..)
+ , L.PeriodGrp(..)
+ , L.CommaGrp(..)
+
-- ** Runtime
, S.Runtime
, S.environment
@@ -84,7 +87,11 @@
-- 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
@@ -100,12 +107,23 @@
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.
@@ -142,9 +160,10 @@
-- If this list is empty, then by default postings are left in the
-- same order as they appear in the ledger files.
- , balanceFormat :: L.Commodity -> L.Qty -> X.Text
- -- ^ How to format balances in the balance report. Change this
- -- function if, for example, you want to allow for digit grouping.
+ , 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;
@@ -168,10 +187,6 @@
, convertSortBy :: CP.SortBy
-- ^ Sort by account or by quantity in the convert report.
- , convertFormat :: L.Commodity -> L.Qty -> X.Text
- -- ^ How to format balances in the convert report. For instance,
- -- this function might perform digit grouping.
-
, postingsFields :: Fields Bool
-- ^ Fields to show by default in the postings report.
@@ -186,16 +201,6 @@
, postingsDateFormat :: (M.PostMeta, L.Posting) -> X.Text
-- ^ How to format dates in the postings report.
- , postingsQtyFormat :: (M.PostMeta, L.Posting) -> X.Text
- -- ^ How to format quantities in the balance report. This function
- -- is used when showing the quantity for the posting itself, and
- -- not the quantity for the totals columns (for that, see
- -- postingsBalanceFormat.) For example this function might perform
- -- digit grouping.
-
- , postingsBalanceFormat :: L.Commodity -> L.Qty -> X.Text
- -- ^ How to format balance totals 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
@@ -230,6 +235,119 @@
-- 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
@@ -278,7 +396,7 @@
cd = toConvertDefaults df
pd = toPostingsDefaults df
in [ Ps.zincReport pd
- , MC.parseReport (balanceFormat df) bd
+ , MC.parseReport bd
, Conv.cmdLineReport cd
]
@@ -292,6 +410,7 @@
, Z.moreSchemes = additionalSchemes d
, Z.sorter = sorter d
, Z.exprDesc = expressionType d
+ , Z.formatQty = formatQty d
}
toBalanceDefaults :: Defaults -> MP.ParseOpts
@@ -308,7 +427,6 @@
, ConvOpts.target = convTarget . convertTarget $ d
, ConvOpts.sortOrder = convertOrder d
, ConvOpts.sortBy = convertSortBy d
- , ConvOpts.format = convertFormat d
}
toPostingsDefaults :: Defaults -> Ps.ZincOpts
@@ -318,8 +436,6 @@
, Ps.showZeroBalances =
CO.ShowZeroBalances . postingsShowZeroBalances $ d
, Ps.dateFormat = postingsDateFormat d
- , Ps.qtyFormat = postingsQtyFormat d
- , Ps.balanceFormat = postingsBalanceFormat d
, Ps.subAccountLength =
Ps.SubAccountLength . postingsSubAccountLength $ d
, Ps.payeeAllocation =
@@ -328,9 +444,6 @@
Ps.alloc . postingsAccountAllocation $ d
, Ps.spacers = convSpacers . postingsSpacers $ d
}
-
-defaultQtyFormat :: L.Qty -> X.Text
-defaultQtyFormat = X.pack . L.prettyShowQty
data Spacers a = Spacers
{ sGlobalTransaction :: a
diff --git a/lib/Penny/Brenner.hs b/lib/Penny/Brenner.hs
--- a/lib/Penny/Brenner.hs
+++ b/lib/Penny/Brenner.hs
@@ -8,8 +8,10 @@
module Penny.Brenner
( FitAcct(..)
, Config(..)
- , R.GroupSpecs(..)
- , R.GroupSpec(..)
+ , Su.S3(..)
+ , L.Radix(..)
+ , L.PeriodGrp(..)
+ , L.CommaGrp(..)
, Y.Translator(..)
, L.Side(..)
, L.SpaceBetween(..)
@@ -19,14 +21,11 @@
) where
import qualified Penny.Brenner.Types as Y
-import Control.Monad (join)
-import Data.Either (partitionEithers)
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.Copper.Render as R
import qualified Penny.Brenner.Clear as C
import qualified Penny.Brenner.Database as D
import qualified Penny.Brenner.Import as I
@@ -34,8 +33,10 @@
import qualified Penny.Brenner.Merge as M
import qualified Penny.Brenner.OFX as O
import qualified Penny.Brenner.Print as P
-import qualified Penny.Brenner.Util as U
+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.
@@ -46,44 +47,37 @@
-> IO ()
brennerMain v cf = do
let cf' = convertConfig cf
- join $ MA.modesWithHelp (help False) (globalOpts v)
- (preProcessor 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.OptSpec (Either (IO ()) Y.FitAcctName)]
-globalOpts v =
+ -> MA.Opts GetHelp Y.FitAcctName
+globalOpts v = MA.optsHelpVersion help (Ly.version v)
[ MA.OptSpec ["fit-account"] "f"
- (MA.OneArg (Right . Y.FitAcctName . X.pack))
- , fmap Left (Ly.version v)
+ (MA.OneArg (Y.FitAcctName . X.pack))
]
-- | Pre-processes global options for a pre-compiled configuration.
preProcessor
:: Y.Config
- -> [Either (IO ()) Y.FitAcctName]
- -> Either (a -> IO ()) [MA.Mode (IO ())]
-preProcessor cf args =
- let (vers, as) = partitionEithers args
- in case vers of
- [] -> makeModes Nothing cf as
- x:_ -> Left (const x)
-
--- | Makes modes for a pre-compiled configuration.
-makeModes
- :: Maybe Y.ConfigLocation
- -> Y.Config
-> [Y.FitAcctName]
- -- ^ Names of financial institutions given on command line
- -> Either (a -> IO ()) [MA.Mode (IO ())]
-makeModes cl cf as = Ex.toEither . Ex.mapException (const . U.errExit) $ do
- mayFi <- case as of
+ -> 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 as
+ s = last args
toFilter = case Y.defaultFitAcct cf of
Nothing -> Y.moreFitAccts cf
Just d -> d : Y.moreFitAccts cf
@@ -96,34 +90,33 @@
"more than one financial institution account "
++ "named " ++ (X.unpack . Y.unFitAcctName $ s)
++ " configured."
- return . map (fmap (\f -> f cl cf mayFi)) $ allModes
+ 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.
-type ModeFunc
- = Maybe Y.ConfigLocation
- -> Y.Config
- -> Maybe Y.FitAcct
- -> IO ()
-allModes :: [MA.Mode ModeFunc]
-allModes =
- fmap (\f cl cf _ -> f cl cf) Info.mode
- : map (fmap (const . const))
- [C.mode, I.mode, M.mode, P.mode, D.mode]
+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
- :: Bool
- -- ^ True if running under a dynamic configuration
- -> String
+ :: String
-- ^ Program name
-> String
-help dyn n = unlines ls
+help n = unlines ls
where
ls = [ "usage: " ++ n ++ " [global-options]"
++ " COMMAND [local-options]"
@@ -142,11 +135,7 @@
, " (use the \"info\" command to see which are available)."
, " If this option does not appear,"
, " the default account is used if there is one."
- ] ++ if not dyn then [] else
- [ ""
- , "-c, --config-file FILENAME"
- , " Specify configuration file location"
- ]
+ ]
-- | Information to configure a single financial institution account.
data FitAcct = FitAcct
@@ -177,10 +166,9 @@
, currency :: String
-- ^ The commodity for the currency of your card (e.g. @$@).
- , groupSpecs :: R.GroupSpecs
- -- ^ How to group digits when printing the resulting ledger. All
- -- quantities (not just those affected by this program) will be
- -- formatted using this specification.
+ , qtySpec :: Su.S3 L.Radix L.PeriodGrp L.CommaGrp
+ -- ^ How to group digits when printing the resulting ledger.
+ -- This affects only the postings created from the statement.
, translator :: Y.Translator
-- ^ See the documentation under the 'Translator' type for
@@ -232,7 +220,7 @@
, 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.groupSpecs = gs
+ , Y.qtySpec = gs
, Y.translator = tl
, Y.side = sd
, Y.spaceBetween = sb
diff --git a/lib/Penny/Brenner/Clear.hs b/lib/Penny/Brenner/Clear.hs
--- a/lib/Penny/Brenner/Clear.hs
+++ b/lib/Penny/Brenner/Clear.hs
@@ -60,18 +60,18 @@
} deriving Show
-mode :: MA.Mode (Maybe Y.FitAcct -> IO ())
-mode = MA.Mode
- { MA.mName = "clear"
- , MA.mIntersperse = MA.Intersperse
- , MA.mOpts = [fmap AOutput Ly.output]
- , MA.mPosArgs = return . APosArg
- , MA.mProcess = process
- , MA.mHelp = help
- }
+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 :: [Arg] -> Maybe Y.FitAcct -> IO ()
-process as mayFa = do
+
+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."
@@ -96,7 +96,7 @@
when (not (Set.null left))
(fail $ "some postings were not cleared. "
++ "Those not cleared:\n" ++ ppShow left)
- case mapM (R.item (Y.groupSpecs c)) led'' of
+ case mapM (R.item Nothing) led'' of
Nothing ->
fail "could not render resulting ledger."
Just txts ->
diff --git a/lib/Penny/Brenner/Database.hs b/lib/Penny/Brenner/Database.hs
--- a/lib/Penny/Brenner/Database.hs
+++ b/lib/Penny/Brenner/Database.hs
@@ -16,21 +16,20 @@
data Arg = ArgPos String
-mode :: MA.Mode (Maybe Y.FitAcct -> IO ())
-mode = MA.Mode
- { MA.mName = "database"
- , MA.mIntersperse = MA.Intersperse
- , MA.mOpts = []
- , MA.mPosArgs = return . ArgPos
- , MA.mProcess = processor
- , MA.mHelp = help
- }
+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
- :: [Arg]
- -> Maybe Y.FitAcct
+ :: Maybe Y.FitAcct
+ -> [Arg]
-> IO ()
-processor ls mayFa
+processor mayFa ls
| not . null $ ls = fail $
"penny-fit database: error: this command does"
++ " not accept non-option arguments."
diff --git a/lib/Penny/Brenner/Import.hs b/lib/Penny/Brenner/Import.hs
--- a/lib/Penny/Brenner/Import.hs
+++ b/lib/Penny/Brenner/Import.hs
@@ -32,27 +32,27 @@
, newUNumber :: Maybe Integer
}
-mode
- :: MA.Mode (Maybe Y.FitAcct -> IO ())
-mode = MA.Mode
- { MA.mName = "import"
- , MA.mIntersperse = MA.Intersperse
- , MA.mOpts =
+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
]
- , MA.mPosArgs = return . AFitFile
- , MA.mProcess = processor
- , MA.mHelp = help
- }
processor
- :: [Arg]
- -> Maybe Y.FitAcct
+ :: Maybe Y.FitAcct
+ -> [Arg]
-> IO ()
-processor as mayFa = do
+processor mayFa as = do
fa <- U.getFitAcct mayFa
let (dbLoc, prsr) = (Y.dbLocation fa, snd . Y.parser $ fa)
loc <- case mapMaybe toFitFile as of
diff --git a/lib/Penny/Brenner/Info.hs b/lib/Penny/Brenner/Info.hs
--- a/lib/Penny/Brenner/Info.hs
+++ b/lib/Penny/Brenner/Info.hs
@@ -7,7 +7,7 @@
import qualified Data.Text.IO as TIO
import Data.Monoid ((<>))
import qualified Penny.Lincoln as L
-import qualified Penny.Copper.Render as R
+import qualified Penny.Steel.Sums as S
import qualified System.Console.MultiArg as MA
help :: String -> String
@@ -20,26 +20,25 @@
, " -h, --help - show help and exit"
]
-mode :: MA.Mode (Maybe Y.ConfigLocation -> Y.Config -> IO ())
-mode = MA.Mode
- { MA.mName = "info"
- , MA.mIntersperse = MA.Intersperse
- , MA.mOpts = []
- , MA.mPosArgs = const . Ex.throw . MA.ErrorMsg
- $ "this mode does not accept positional arguments"
- , MA.mProcess = const process
- , MA.mHelp = help
- }
+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 :: Maybe Y.ConfigLocation -> Y.Config -> IO ()
-process cf cn = TIO.putStr $ showInfo cf cn
+process :: Y.Config -> IO ()
+process cf = TIO.putStr $ showInfo cf
-showInfo :: Maybe Y.ConfigLocation -> Y.Config -> X.Text
-showInfo cf cn =
- maybe "These settings are compiled into your program.\n\n"
- (\l -> label "From configuration file at" (L.text l) <> "\n\n")
- cf
- <> showConfig cn
+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) =
@@ -73,11 +72,8 @@
, 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 "Group amounts to left of decimal point"
- (showGroupLeft . R.left . Y.groupSpecs $ c)
-
- , label "Group amounts to right of decimal point"
- (showGroupRight . R.right . Y.groupSpecs $ c)
+ , label "Radix point and digit grouping"
+ (showQtySpec . Y.qtySpec $ c)
, label "Financial institution increases are"
(showTranslator . Y.translator $ c)
@@ -91,17 +87,17 @@
<> "Parser description:\n"
<> (L.text . fst . Y.parser $ c)
-showGroupLeft :: R.GroupSpec -> X.Text
-showGroupLeft s = case s of
- R.NoGrouping -> "never"
- R.GroupLarge -> "when greater than 9,999"
- R.GroupAll -> "always"
+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: ','"
-showGroupRight :: R.GroupSpec -> X.Text
-showGroupRight s = case s of
- R.NoGrouping -> "never"
- R.GroupLarge -> "when mor than four decimal places"
- R.GroupAll -> "always"
showTranslator :: Y.Translator -> X.Text
showTranslator y = case y of
diff --git a/lib/Penny/Brenner/Merge.hs b/lib/Penny/Brenner/Merge.hs
--- a/lib/Penny/Brenner/Merge.hs
+++ b/lib/Penny/Brenner/Merge.hs
@@ -36,20 +36,21 @@
toOutput :: Arg -> Maybe (X.Text -> IO ())
toOutput a = case a of { AOutput x -> Just x; _ -> Nothing }
-mode :: MA.Mode (Maybe Y.FitAcct -> IO ())
-mode = MA.Mode
- { MA.mName = "merge"
- , MA.mIntersperse = MA.Intersperse
- , MA.mOpts = [ MA.OptSpec ["no-auto"] "n" (MA.NoArg ANoAuto)
- , fmap AOutput Ly.output
- ]
- , MA.mPosArgs = return . APos
- , MA.mProcess = processor
- , MA.mHelp = help
- }
+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 :: [Arg] -> Maybe Y.FitAcct -> IO ()
-processor as mayFa = do
+processor :: Maybe Y.FitAcct -> [Arg] -> IO ()
+processor mayFa as = do
fa <- U.getFitAcct mayFa
doMerge fa
(ANoAuto `elem` as)
@@ -72,7 +73,7 @@
l (filterDb (Y.pennyAcct acct) dbWithEntry l)
newTxns = createTransactions noAuto acct l dbLs db'
final = l' ++ newTxns
- case mapM (R.item (Y.groupSpecs acct)) (map C.stripMeta final) of
+ case mapM (R.item Nothing) (map C.stripMeta final) of
Nothing -> fail "Could not render final ledger."
Just txts ->
let txt = X.concat txts
@@ -206,7 +207,7 @@
-- | 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)
+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)
@@ -214,7 +215,7 @@
qty = U.parseQty (Y.amount p)
cty = Y.unCurrency . Y.currency $ acct
-type DbWithEntry = M.Map Y.UNumber (Y.Posting, L.Entry)
+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
@@ -224,22 +225,29 @@
:: Y.FitAcct
-> L.TopLineData
-> L.Ent L.PostingData
- -> (a, (Y.Posting, L.Entry))
+ -> (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 (L.qty . L.amount . L.entry $ pstg)
+ mQ = L.equivalent (eitherToQty . L.entry $ pstg)
(L.qty . L.amount $ e)
- mDC = (L.drCr e) == (L.drCr . L.entry $ pstg)
+ 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 = (L.commodity . L.amount . L.entry $ pstg)
+ 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.
@@ -248,9 +256,10 @@
-> Y.FitAcct
-> UNumberLookupMap
-> PyeLookupMap
- -> (Y.UNumber, (Y.Posting, L.Entry))
+ -> (Y.UNumber, (Y.Posting, L.Entry L.Qty))
-> L.Transaction
-newTransaction noAuto acct mu mp (u, (a, e)) = L.Transaction (tld, ents) where
+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 }
@@ -271,8 +280,9 @@
}
p2core = L.emptyPostingCore ac
ents = L.rEnts (Y.unCurrency . Y.currency $ acct) (L.drCr e)
- (L.qty . L.amount $ e, p1data)
+ (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.
diff --git a/lib/Penny/Brenner/Print.hs b/lib/Penny/Brenner/Print.hs
--- a/lib/Penny/Brenner/Print.hs
+++ b/lib/Penny/Brenner/Print.hs
@@ -23,22 +23,20 @@
data Arg
= ArgFile String
-mode
- :: MA.Mode (Maybe Y.FitAcct -> IO ())
-mode = MA.Mode
- { MA.mName = "print"
- , MA.mIntersperse = MA.Intersperse
- , MA.mOpts = []
- , MA.mPosArgs = return . ArgFile
- , MA.mProcess = processor
- , MA.mHelp = help
- }
+mode :: Y.Mode
+mode mayFa = MA.modeHelp
+ "print"
+ help
+ (processor mayFa)
+ []
+ MA.Intersperse
+ (return . ArgFile)
processor
- :: [Arg]
- -> Maybe Y.FitAcct
+ :: Maybe Y.FitAcct
+ -> [Arg]
-> IO ()
-processor ls mayFa = do
+processor mayFa ls = do
fa <- U.getFitAcct mayFa
doPrint (snd . Y.parser $ fa) ls
diff --git a/lib/Penny/Brenner/Types.hs b/lib/Penny/Brenner/Types.hs
--- a/lib/Penny/Brenner/Types.hs
+++ b/lib/Penny/Brenner/Types.hs
@@ -11,7 +11,6 @@
, DbMap
, DbList
, Posting(..)
- , ConfigLocation(..)
, DbLocation(..)
, FitAcctName(..)
, FitAcctDesc(..)
@@ -25,18 +24,23 @@
, 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.Copper.Render as R
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)
@@ -196,13 +200,6 @@
<*> S.get
<*> S.get
--- | Where is a configuration file
-newtype ConfigLocation = ConfigLocation
- { unConfigLocation :: Text }
- deriving (Eq, Show)
-
-instance L.HasText ConfigLocation where text = unConfigLocation
-
-- | Where is the database of postings?
newtype DbLocation = DbLocation { unDbLocation :: Text }
deriving (Eq, Show)
@@ -277,7 +274,10 @@
, pennyAcct :: PennyAcct
, defaultAcct :: DefaultAcct
, currency :: Currency
- , groupSpecs :: R.GroupSpecs
+
+ , qtySpec :: Su.S3 L.Radix L.PeriodGrp L.CommaGrp
+ -- ^ How to turn Qty into QtyRep.
+
, translator :: Translator
, side :: L.Side
diff --git a/lib/Penny/Brenner/Util.hs b/lib/Penny/Brenner/Util.hs
--- a/lib/Penny/Brenner/Util.hs
+++ b/lib/Penny/Brenner/Util.hs
@@ -10,13 +10,13 @@
import qualified Text.Parsec as P
import qualified Penny.Lincoln as L
import qualified System.Exit as Exit
-import qualified System.Console.MultiArg as MA
import qualified System.IO as IO
+import System.Environment (getProgName)
-- | Print an error message and exit.
errExit :: String -> IO a
errExit s = do
- pn <- MA.getProgName
+ pn <- getProgName
IO.hPutStrLn IO.stderr $ pn ++ ": error: " ++ s
Exit.exitFailure
@@ -79,10 +79,10 @@
-- 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.quantity "" (Y.unAmount a) of
+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 -> g
+ Right g -> L.toQty g
label :: String -> X.Text -> String
label s x = s ++ ": " ++ X.unpack x ++ "\n"
diff --git a/lib/Penny/Cabin/Balance/Convert.hs b/lib/Penny/Cabin/Balance/Convert.hs
--- a/lib/Penny/Cabin/Balance/Convert.hs
+++ b/lib/Penny/Cabin/Balance/Convert.hs
@@ -36,7 +36,7 @@
-- need to use if you are supplying options programatically (as
-- opposed to parsing them in from the command line.)
data Opts = Opts
- { balanceFormat :: L.Commodity -> L.Qty -> X.Text
+ { balanceFormat :: L.Amount L.Qty -> X.Text
, showZeroBalances :: CO.ShowZeroBalances
, sorter :: Sorter
, target :: L.To
@@ -48,16 +48,16 @@
-- 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)
+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
+convertBalance
+ :: L.PriceDb
-> L.DateTime
-> L.To
-> L.Balance
@@ -68,8 +68,8 @@
-- | Converts a single BottomLine to a new commodity. Fails with an
-- error message if no conversion data is available.
-convertOne ::
- L.PriceDb
+convertOne
+ :: L.PriceDb
-> L.DateTime
-> L.To
-> (L.Commodity, L.BottomLine)
@@ -85,8 +85,8 @@
g r = L.NonZero (L.Column dc r)
-- | Creates an error message for conversion errors.
-convertError ::
- L.To
+convertError
+ :: L.To
-> L.From
-> L.PriceDbError
-> X.Text
@@ -154,7 +154,7 @@
report os@(Opts getFmt _ _ _ _ txtFormats) ps bs = do
fstBl <- sumConvertSort os ps bs
let (rs, L.To cy) = rows fstBl
- fmt = getFmt cy
+ fmt q = getFmt (L.Amount q cy)
return $ K.rowsToChunks txtFormats fmt rs
@@ -165,15 +165,15 @@
-> I.Report
cmdLineReport o rt = (help o, mkMode)
where
- mkMode _ _ chgrs _ fsf = MA.Mode
- { MA.mName = "convert"
- , MA.mIntersperse = MA.Intersperse
- , MA.mOpts = map (fmap Right) P.allOptSpecs
- , MA.mPosArgs = return . Left
- , MA.mProcess = process rt chgrs o fsf
- , MA.mHelp = const (help o)
- }
+ 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
@@ -189,9 +189,9 @@
Ex.Success g -> return $
let noDefault = X.pack "no default price found"
f = fromParsedOpts chgrs g
- pr ts pps = do
+ pr fmt ts pps = do
rptOpts <- Ex.fromMaybe noDefault $
- f pps (O.format defaultOpts)
+ f pps fmt
let boxes = fsf ts
report rptOpts pps boxes
in (posArgs, pr)
@@ -223,9 +223,10 @@
mostFrequent = U.lastMode . map (L.to . L.price)
-type DoReport = [L.PricePoint]
- -> (L.Commodity -> L.Qty -> X.Text)
- -> (Maybe Opts)
+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
diff --git a/lib/Penny/Cabin/Balance/Convert/Options.hs b/lib/Penny/Cabin/Balance/Convert/Options.hs
--- a/lib/Penny/Cabin/Balance/Convert/Options.hs
+++ b/lib/Penny/Cabin/Balance/Convert/Options.hs
@@ -5,9 +5,7 @@
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.Lincoln as L
import qualified Penny.Shield as S
-import qualified Data.Text as X
-- | Default options for the Convert report. This record is used as
-- the starting point when parsing in options from the command
@@ -19,7 +17,6 @@
, target :: P.Target
, sortOrder :: CP.SortOrder
, sortBy :: P.SortBy
- , format :: L.Commodity -> L.Qty -> X.Text
}
toParserOpts :: DefaultOpts -> S.Runtime -> P.Opts
@@ -37,7 +34,6 @@
, target = P.AutoTarget
, sortOrder = CP.Ascending
, sortBy = P.SortByName
- , format = \_ q -> X.pack . L.prettyShowQty $ q
}
diff --git a/lib/Penny/Cabin/Balance/MultiCommodity.hs b/lib/Penny/Cabin/Balance/MultiCommodity.hs
--- a/lib/Penny/Cabin/Balance/MultiCommodity.hs
+++ b/lib/Penny/Cabin/Balance/MultiCommodity.hs
@@ -5,7 +5,6 @@
Opts(..),
defaultOpts,
defaultParseOpts,
- defaultFormat,
parseReport,
defaultReport,
report
@@ -34,15 +33,15 @@
-- needed to make the report if the options are not being parsed in
-- from the command line.
data Opts = Opts
- { balanceFormat :: L.Commodity -> L.Qty -> X.Text
+ { balanceFormat :: L.Amount L.Qty -> X.Text
, showZeroBalances :: CO.ShowZeroBalances
, order :: L.SubAccount -> L.SubAccount -> Ordering
, textFormats :: E.Changers
}
-defaultOpts :: Opts
-defaultOpts = Opts
- { balanceFormat = defaultFormat
+defaultOpts :: (L.Amount L.Qty -> X.Text) -> Opts
+defaultOpts fmt = Opts
+ { balanceFormat = fmt
, showZeroBalances = CO.ShowZeroBalances True
, order = compare
, textFormats = Schemes.darkLabels
@@ -56,7 +55,7 @@
fromParseOpts
:: E.Changers
- -> (L.Commodity -> L.Qty -> X.Text)
+ -> (L.Amount L.Qty -> X.Text)
-> P.ParseOpts
-> Opts
fromParseOpts chgrs fmt (P.ParseOpts szb o) = Opts fmt szb o' chgrs
@@ -65,9 +64,6 @@
CP.Ascending -> compare
CP.Descending -> CO.descending compare
-defaultFormat :: a -> L.Qty -> X.Text
-defaultFormat _ = X.pack . L.prettyShowQty
-
summedSortedBalTree ::
CO.ShowZeroBalances
-> (L.SubAccount -> L.SubAccount -> Ordering)
@@ -100,48 +96,43 @@
-- | The MultiCommodity report with configurable options that have
-- been parsed from the command line.
-parseReport ::
- (L.Commodity -> L.Qty -> X.Text)
- -- ^ How to format balances. For instance you can use this to
- -- perform commodity-sensitive digit grouping.
-
- -> P.ParseOpts
+parseReport
+ :: P.ParseOpts
-- ^ Default options for the report. These can be overriden on the
-- command line.
-> I.Report
-parseReport fmt o rt = (help o, makeMode)
+parseReport o rt = (help o, makeMode)
where
- makeMode _ _ chgrs _ fsf = MA.Mode
- { MA.mName = "balance"
- , MA.mIntersperse = MA.Intersperse
- , MA.mOpts = map (fmap Right) P.allSpecs
- , MA.mPosArgs = return . Left
- , MA.mProcess = process chgrs fmt o rt fsf
- , MA.mHelp = const (help o)
- }
+ 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
- -> (L.Commodity -> L.Qty -> X.Text)
-> P.ParseOpts
-> a
-> ([L.Transaction] -> [(Ly.LibertyMeta, L.Posting)])
-> [Either String (P.ParseOpts -> P.ParseOpts)]
-> f I.ArgsAndReport
-process chgrs fmt o _ fsf ls =
+process chgrs o _ fsf ls =
let (posArgs, fns) = Ei.partitionEithers ls
mkParsedOpts = foldl (flip (.)) id fns
os' = mkParsedOpts o
- mcOpts = fromParseOpts chgrs fmt os'
- pr txns _ = return $ report mcOpts (fsf txns)
+ 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 defaultFormat defaultParseOpts
+defaultReport = parseReport defaultParseOpts
------------------------------------------------------------
-- ## Help
diff --git a/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs b/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs
--- a/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs
+++ b/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs
@@ -149,7 +149,7 @@
rowsToChunks
:: E.Changers
- -> (L.Commodity -> L.Qty -> X.Text)
+ -> (L.Amount L.Qty -> X.Text)
-- ^ How to format a balance to allow for digit grouping
-> [Row]
-> [Rb.Chunk]
@@ -159,7 +159,7 @@
rowsToColumns
:: E.Changers
- -> (L.Commodity -> L.Qty -> X.Text)
+ -> (L.Amount L.Qty -> X.Text)
-- ^ How to format a balance to allow for digit grouping
-> [Row]
@@ -171,7 +171,7 @@
mkColumn
:: E.Changers
- -> (L.Commodity -> L.Qty -> X.Text)
+ -> (L.Amount L.Qty -> X.Text)
-> (Meta.VisibleNum, Row)
-> Columns PreSpec
mkColumn chgrs fmt (vn, (Row i acctTxt bs)) = Columns ca cd cc cq
@@ -208,7 +208,7 @@
balanceChunks
:: E.Changers
- -> (L.Commodity -> L.Qty -> X.Text)
+ -> (L.Amount L.Qty -> X.Text)
-> E.EvenOdd
-> (L.Commodity, L.BottomLine)
-> (Rb.Chunk, Rb.Chunk, Rb.Chunk)
diff --git a/lib/Penny/Cabin/Balance/Util.hs b/lib/Penny/Cabin/Balance/Util.hs
--- a/lib/Penny/Cabin/Balance/Util.hs
+++ b/lib/Penny/Cabin/Balance/Util.hs
@@ -162,8 +162,11 @@
boxesBalance :: [(a, L.Posting)] -> L.Balance
-boxesBalance = mconcat . map L.entryToBalance . map Q.entry
- . map snd
+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)
diff --git a/lib/Penny/Cabin/Interface.hs b/lib/Penny/Cabin/Interface.hs
--- a/lib/Penny/Cabin/Interface.hs
+++ b/lib/Penny/Cabin/Interface.hs
@@ -34,21 +34,28 @@
type ParseResult = Exceptional X.Text ArgsAndReport
type PrintReport
- = [L.Transaction]
- -- ^ All transactions; the report must sort and filter them
+ = (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.
+ -- 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)
@@ -74,4 +81,4 @@
-- ^ Result from previous parsers that will sort and filter incoming
-- transactions
- -> MA.Mode ParseResult
+ -> MA.Mode (MA.ProgName -> String) ParseResult
diff --git a/lib/Penny/Cabin/Posts.hs b/lib/Penny/Cabin/Posts.hs
--- a/lib/Penny/Cabin/Posts.hs
+++ b/lib/Penny/Cabin/Posts.hs
@@ -44,8 +44,6 @@
, A.SubAccountLength(..)
, A.alloc
, yearMonthDay
- , qtyAsIs
- , balanceAsIs
, defaultWidth
, columnsVarToWidth
, widthFromRuntime
@@ -113,14 +111,13 @@
zincReport :: ZincOpts -> I.Report
zincReport opts rt = (helpStr opts, md)
where
- md cs fty ch expr fsf = MA.Mode
- { MA.mName = "postings"
- , MA.mIntersperse = MA.Intersperse
- , MA.mOpts = specs rt
- , MA.mPosArgs = return . Left
- , MA.mProcess = process opts cs fty ch expr fsf
- , MA.mHelp = const (helpStr opts)
- }
+ 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
@@ -152,13 +149,14 @@
-> I.ArgsAndReport
mkPrintReport posArgs zo ch fsf st = (posArgs, f)
where
- f txns _ = do
+ 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 st zo) boxes
+ (P.postFilter st) (chunkOpts fmt st zo) boxes
expChks = showExpression (P.showExpression st) pdct
- verbChks = showVerboseFilter (P.verboseFilter st) pdct boxes
+ verbChks = showVerboseFilter fmt (P.verboseFilter st)
+ pdct boxes
chks = expChks
++ verbChks
++ rptChks
@@ -181,16 +179,17 @@
chks = Pe.showPdct indentAmt 0 pdct
showVerboseFilter
- :: P.VerboseFilter
+ :: (L.Amount L.Qty -> X.Text)
+ -> P.VerboseFilter
-> Pe.Pdct (Ly.LibertyMeta, L.Posting)
-> [(Ly.LibertyMeta, L.Posting)]
-> [Rb.Chunk]
-showVerboseFilter (P.VerboseFilter b) pdct bs =
+showVerboseFilter fmt (P.VerboseFilter b) pdct bs =
if not b then [] else info : blankLine : (chks ++ [blankLine])
where
chks =
fst
- $ Pe.verboseFilter (L.display . snd) indentAmt False pdct bs
+ $ Pe.verboseFilter ((L.display fmt) . snd) indentAmt False pdct bs
info = "Postings report filter:\n"
defaultOptions
@@ -201,8 +200,6 @@
, width = widthFromRuntime rt
, showZeroBalances = CO.ShowZeroBalances False
, dateFormat = yearMonthDay
- , qtyFormat = qtyAsIs
- , balanceFormat = balanceAsIs
, subAccountLength = A.SubAccountLength 2
, payeeAllocation = A.alloc 60
, accountAllocation = A.alloc 40
@@ -243,17 +240,6 @@
-- a PostingInfo so it has lots of information, but it
-- should return a date for use in the Date field.
- , qtyFormat :: (M.PostMeta, L.Posting) -> X.Text
- -- ^ How to display the quantity of the posting. This
- -- function is applied to a Box so it has lots of
- -- information, but it should return a formatted string of
- -- the quantity. Allows you to format digit grouping,
- -- radix points, perform rounding, etc.
-
- , balanceFormat :: L.Commodity -> L.Qty -> X.Text
- -- ^ How to display balance totals. Similar to
- -- balanceFormat.
-
, subAccountLength :: A.SubAccountLength
-- ^ When shortening the names of sub accounts to make
-- them fit, they will be this long.
@@ -276,14 +262,14 @@
}
-chunkOpts ::
- P.State
+chunkOpts
+ :: (L.Amount L.Qty -> X.Text)
+ -> P.State
-> ZincOpts
-> C.ChunkOpts
-chunkOpts s z = C.ChunkOpts
+chunkOpts fmt s z = C.ChunkOpts
{ C.dateFormat = dateFormat z
- , C.qtyFormat = qtyFormat z
- , C.balanceFormat = balanceFormat z
+ , C.qtyFormat = fmt
, C.fields = P.fields s
, C.subAccountLength = subAccountLength z
, C.payeeAllocation = payeeAllocation z
@@ -321,16 +307,6 @@
. snd
$ p
fmt = "%Y-%m-%d"
-
--- | Shows the quantity of a posting. Does no rounding or
--- prettification; simply uses show on the underlying Decimal.
-qtyAsIs :: (M.PostMeta, L.Posting) -> X.Text
-qtyAsIs p = X.pack . L.prettyShowQty . Q.qty . snd $ p
-
--- | Shows the quantity of a balance. If there is no quantity, shows
--- two dashes.
-balanceAsIs :: a -> L.Qty -> X.Text
-balanceAsIs _ = X.pack . L.prettyShowQty
-- | The default width for the report.
defaultWidth :: T.ReportWidth
diff --git a/lib/Penny/Cabin/Posts/Chunk.hs b/lib/Penny/Cabin/Posts/Chunk.hs
--- a/lib/Penny/Cabin/Posts/Chunk.hs
+++ b/lib/Penny/Cabin/Posts/Chunk.hs
@@ -18,8 +18,7 @@
data ChunkOpts = ChunkOpts
{ dateFormat :: (M.PostMeta, L.Posting) -> X.Text
- , qtyFormat :: (M.PostMeta, L.Posting) -> X.Text
- , balanceFormat :: L.Commodity -> L.Qty -> X.Text
+ , qtyFormat :: L.Amount L.Qty -> X.Text
, fields :: F.Fields Bool
, subAccountLength :: A.SubAccountLength
, payeeAllocation :: A.Alloc
@@ -32,7 +31,6 @@
growOpts c = G.GrowOpts
{ G.dateFormat = dateFormat c
, G.qtyFormat = qtyFormat c
- , G.balanceFormat = balanceFormat c
, G.fields = fields c
}
diff --git a/lib/Penny/Cabin/Posts/Growers.hs b/lib/Penny/Cabin/Posts/Growers.hs
--- a/lib/Penny/Cabin/Posts/Growers.hs
+++ b/lib/Penny/Cabin/Posts/Growers.hs
@@ -29,8 +29,7 @@
-- | All the options needed to grow the cells.
data GrowOpts = GrowOpts
{ dateFormat :: (M.PostMeta, L.Posting) -> X.Text
- , qtyFormat :: (M.PostMeta, L.Posting) -> X.Text
- , balanceFormat :: L.Commodity -> L.Qty -> X.Text
+ , qtyFormat :: L.Amount L.Qty -> X.Text
, fields :: F.Fields Bool
}
@@ -115,7 +114,7 @@
, postingQty = \o ch -> getPostingQty ch (qtyFormat o)
, totalDrCr = const getTotalDrCr
, totalCmdty = const getTotalCmdty
- , totalQty = \o ch -> getTotalQty ch (balanceFormat o)
+ , totalQty = \o ch -> getTotalQty ch (qtyFormat o)
}
-- | Make a left justified cell one line long that shows a serial.
@@ -246,8 +245,16 @@
getPostingCmdty ch i = coloredPostingCell ch t i where
t = L.unCommodity . Q.commodity . snd $ i
-getPostingQty :: E.Changers -> ((M.PostMeta, L.Posting) -> X.Text) -> (M.PostMeta, L.Posting) -> PreSpec
-getPostingQty ch qf i = coloredPostingCell ch (qf i) 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 =
@@ -280,7 +287,7 @@
getTotalQty
:: E.Changers
- -> (L.Commodity -> L.Qty -> X.Text)
+ -> (L.Amount L.Qty -> X.Text)
-> (M.PostMeta, L.Posting)
-> PreSpec
getTotalQty ch balFmt i =
diff --git a/lib/Penny/Cabin/Posts/Meta.hs b/lib/Penny/Cabin/Posts/Meta.hs
--- a/lib/Penny/Cabin/Posts/Meta.hs
+++ b/lib/Penny/Cabin/Posts/Meta.hs
@@ -73,7 +73,8 @@
-> (a, L.Posting)
-> (L.Balance, (L.Balance, (a, L.Posting)))
balanceAccum (CO.ShowZeroBalances szb) balOld (x, po) =
- let balThis = L.entryToBalance . Q.entry $ 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
diff --git a/lib/Penny/Cabin/Scheme.hs b/lib/Penny/Cabin/Scheme.hs
--- a/lib/Penny/Cabin/Scheme.hs
+++ b/lib/Penny/Cabin/Scheme.hs
@@ -115,7 +115,7 @@
balanceToQtys
:: Changers
- -> (L.Commodity -> L.Qty -> X.Text)
+ -> (L.Amount L.Qty -> X.Text)
-> EvenOdd
-> [(L.Commodity, L.BottomLine)]
-> [R.Chunk]
@@ -128,7 +128,7 @@
bottomLineToQty
:: Changers
- -> (L.Commodity -> L.Qty -> X.Text)
+ -> (L.Amount L.Qty -> X.Text)
-> EvenOdd
-> (L.Commodity, L.BottomLine)
-> R.Chunk
@@ -136,6 +136,7 @@
where
(lbl, t) = case bl of
L.Zero -> (Zero, X.pack "--")
- L.NonZero (L.Column clmDrCr qt) -> (dcToLbl clmDrCr, getTxt cy qt)
+ L.NonZero (L.Column clmDrCr qt) ->
+ (dcToLbl clmDrCr, getTxt (L.Amount qt cy))
md = getEvenOddLabelValue lbl eo chgrs
diff --git a/lib/Penny/Copper.hs b/lib/Penny/Copper.hs
--- a/lib/Penny/Copper.hs
+++ b/lib/Penny/Copper.hs
@@ -82,8 +82,6 @@
, module Penny.Copper.Interface
-- * Rendering
- , R.GroupSpec(..)
- , R.GroupSpecs(..)
, R.item
diff --git a/lib/Penny/Copper/Interface.hs b/lib/Penny/Copper/Interface.hs
--- a/lib/Penny/Copper/Interface.hs
+++ b/lib/Penny/Copper/Interface.hs
@@ -1,12 +1,7 @@
-{-# LANGUAGE DeriveGeneric #-}
-
module Penny.Copper.Interface where
import qualified Penny.Lincoln as L
import qualified Data.Text as X
-import qualified Data.Text.Encoding as XE
-import GHC.Generics (Generic)
-import qualified Data.Binary as B
import qualified Penny.Steel.Sums as S
data ParsedTopLine = ParsedTopLine
@@ -16,27 +11,19 @@
, ptlPayee :: Maybe L.Payee
, ptlMemo :: Maybe (L.Memo, L.TopMemoLine)
, ptlTopLineLine :: L.TopLineLine
- } deriving (Show, Generic)
+ } deriving (Show)
toTopLineCore :: ParsedTopLine -> L.TopLineCore
toTopLineCore (ParsedTopLine dt nu fl pa me _)
= L.TopLineCore dt nu fl pa (fmap fst me)
-instance B.Binary ParsedTopLine
-
type ParsedTxn = (ParsedTopLine , L.Ents (L.PostingCore, L.PostingLine))
data BlankLine = BlankLine
- deriving (Eq, Show, Generic)
-
-instance B.Binary BlankLine
+ deriving (Eq, Show)
newtype Comment = Comment { unComment :: X.Text }
deriving (Eq, Show)
-
-instance B.Binary Comment where
- get = fmap (Comment . XE.decodeUtf8) B.get
- put = B.put . XE.encodeUtf8 . unComment
type ParsedItem =
S.S4 ParsedTxn L.PricePoint Comment BlankLine
diff --git a/lib/Penny/Copper/Parsec.hs b/lib/Penny/Copper/Parsec.hs
--- a/lib/Penny/Copper/Parsec.hs
+++ b/lib/Penny/Copper/Parsec.hs
@@ -2,10 +2,12 @@
-- documented in EBNF in the file @doc\/ledger-grammar.org@.
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 Text.Parsec (many, many1, satisfy, ())
import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as Pos
import Control.Applicative.Permutation (runPerms, maybeAtom)
@@ -13,6 +15,7 @@
(<|>), 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)
@@ -24,6 +27,13 @@
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)
@@ -64,6 +74,8 @@
ledgerAcct :: Parser L.Account
ledgerAcct = quotedLvl1Acct <|> lvl2Acct
+-- # Commodities
+
lvl1Cmdty :: Parser L.Commodity
lvl1Cmdty = (L.Commodity . pack) <$> many1 (satisfy T.lvl1CmdtyChar)
@@ -80,61 +92,141 @@
lvl3Cmdty :: Parser L.Commodity
lvl3Cmdty = (L.Commodity . pack) <$> many1 (satisfy T.lvl3CmdtyChar)
-digitGroup :: Parser [Char]
-digitGroup = satisfy T.thinSpace *> many1 (satisfy T.digit)
+-- # Quantities
-digitSequence :: Parser [Char]
-digitSequence =
- (++) <$> many1 (satisfy T.digit)
- <*> (concat <$> (many digitGroup))
+digit :: Parser L.Digit
+digit = (P.choice . map f $ zip ['0'..'9'] [minBound..maxBound])
+ "digit"
+ where
+ f (s, d) = d <$ P.char s
-digitPostSequence :: Parser (Maybe [Char])
-digitPostSequence = satisfy T.period *> optional digitSequence
+digitList :: Parser L.DigitList
+digitList = L.DigitList <$> nonEmpty digit
-quantity :: Parser L.Qty
-quantity = p >>= failOnErr
- where
- p = (L.RadFrac <$> (satisfy T.period *> digitSequence))
- <|> (f <$> digitSequence <*> optional digitPostSequence)
- f digSeq maybePostSeq = case maybePostSeq of
- Nothing -> L.Whole digSeq
- Just ps ->
- maybe (L.WholeRad digSeq) (L.WholeRadFrac digSeq) ps
- failOnErr = maybe (fail msg) return . L.toQty
- msg = "could not read quantity; zero quantities not allowed"
+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.Side, L.SpaceBetween)
+leftCmdtyLvl1Amt :: Parser (L.Amount L.QtyRep, L.Side, L.SpaceBetween)
leftCmdtyLvl1Amt =
- f <$> quotedLvl1Cmdty <*> spaceBetween <*> quantity
+ f <$> quotedLvl1Cmdty <*> spaceBetween <*> qtyRep
where
f c s q = (L.Amount q c , L.CommodityOnLeft, s)
-leftCmdtyLvl3Amt :: Parser (L.Amount, L.Side, L.SpaceBetween)
-leftCmdtyLvl3Amt = f <$> lvl3Cmdty <*> spaceBetween <*> quantity
+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.Side, L.SpaceBetween)
+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.Side, L.SpaceBetween)
+rightSideCmdtyAmt :: Parser (L.Amount L.QtyRep, L.Side, L.SpaceBetween)
rightSideCmdtyAmt =
- f <$> quantity <*> spaceBetween <*> rightSideCmdty
+ f <$> qtyRep <*> spaceBetween <*> rightSideCmdty
where
- f q s c = (L.Amount q c ,L.CommodityOnRight, s)
+ f q s c = (L.Amount q c, L.CommodityOnRight, s)
-amount :: Parser (L.Amount, L.Side, L.SpaceBetween)
+amount :: Parser (L.Amount L.QtyRep, L.Side, L.SpaceBetween)
amount = leftSideCmdtyAmt <|> rightSideCmdtyAmt
+-- # Comments
+
comment :: Parser I.Comment
comment =
(I.Comment . pack)
@@ -143,6 +235,8 @@
<* satisfy T.newline
<* many (satisfy T.white)
+-- # Dates and times
+
year :: Parser Integer
year = read <$> replicateM 4 P.digit
@@ -216,6 +310,8 @@
z = fromMaybe L.noOffset mayTz
in ((hr, mn, sec), z)
+-- # Debit and credit
+
debit :: Parser L.DrCr
debit = L.Debit <$ satisfy T.lessThan
@@ -225,15 +321,23 @@
drCr :: Parser L.DrCr
drCr = debit <|> credit
-entry :: Parser (L.Entry, L.Side, L.SpaceBetween)
+-- # 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
@@ -244,6 +348,8 @@
postingMemo :: Parser L.Memo
postingMemo = L.Memo <$> many1 postingMemoLine
+-- ## Transaction memo
+
transactionMemoLine :: Parser Text
transactionMemoLine =
pack
@@ -257,11 +363,15 @@
, 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)
@@ -272,6 +382,8 @@
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)
@@ -294,6 +406,8 @@
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)
@@ -301,6 +415,8 @@
tags :: Parser L.Tags
tags = (\t ts -> L.Tags (t:ts)) <$> tag <*> many tag
+-- # TopLine
+
topLinePayee :: Parser L.Payee
topLinePayee = quotedLvl1Payee <|> lvl2Payee
@@ -333,6 +449,8 @@
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)
@@ -342,7 +460,7 @@
postingAcct :: Parser L.Account
postingAcct = quotedLvl1Acct <|> lvl2Acct
-posting :: Parser (L.PostingCore, L.PostingLine, Maybe L.Entry)
+posting :: Parser (L.PostingCore, L.PostingLine, Maybe (L.Entry L.QtyRep))
posting = f <$> lineNum <* skipWhite
<*> optional flagNumPayee <* skipWhite
<*> postingAcct <* skipWhite
@@ -360,18 +478,24 @@
(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) = (mayEn, (core, lin))
+ 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
@@ -379,6 +503,8 @@
<|> fmap S.S4c comment
<|> (S.S4d I.BlankLine) <$ blankLine
+
+-- # Parsing
parse
:: Text
diff --git a/lib/Penny/Copper/Render.hs b/lib/Penny/Copper/Render.hs
--- a/lib/Penny/Copper/Render.hs
+++ b/lib/Penny/Copper/Render.hs
@@ -1,3 +1,5 @@
+{-# 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
@@ -6,8 +8,8 @@
import Control.Monad (guard)
import Control.Applicative ((<$>), (<|>), (<*>), pure)
-import Data.List (intersperse, intercalate)
-import Data.List.Split (chunksOf, splitOn)
+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
@@ -115,98 +117,63 @@
-- * Quantities
--- | Specifies how to perform digit grouping when rendering a
--- quantity. All grouping groups into groups of 3 digits.
-data GroupSpec =
- NoGrouping
- -- ^ Do not perform any digit grouping
- | GroupLarge
- -- ^ Group digits, but only if the number to be grouped is greater
- -- than 9,999 (if grouping the whole part) or if there are more
- -- than 4 decimal places (if grouping the fractional part).
- | GroupAll
- -- ^ Group digits whenever there are at least four decimal places.
- deriving (Eq, Show)
+-- | 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
-data GroupSpecs = GroupSpecs
- { left :: GroupSpec
- , right :: GroupSpec
- } deriving Show
+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)
-grouper :: String
-grouper = "\x2009"
-
-radix :: String
-radix = "."
-
--- | Performs grouping for amounts to the left of the radix point.
-groupWhole :: GroupSpec -> String -> String
-groupWhole gs o = let
- grouped = intercalate grouper
- . reverse
- . map reverse
- . chunksOf 3
- . reverse
- $ o
- in case gs of
- NoGrouping -> o
- GroupLarge -> if length o > 4 then grouped else o
- GroupAll -> grouped
-
--- | Performs grouping for amounts to the right of the radix point.
-groupDecimal :: GroupSpec -> String -> String
-groupDecimal gs o = let
- grouped = intercalate grouper
- . chunksOf 3
- $ o
- in case gs of
- NoGrouping -> o
- GroupLarge -> if length o > 4 then grouped else o
- GroupAll -> grouped
-
--- | Renders an unquoted Qty. Performs digit grouping as requested.
-quantity
- :: GroupSpecs
- -- ^ Group for the portion to the left and right of the radix point?
-
- -> L.Qty
- -> X.Text
-quantity gs q =
- let qs = L.prettyShowQty q
- in X.pack $ case splitOn "." qs of
- w:[] -> groupWhole (left gs) w
- w:d:[] ->
- groupWhole (left gs) w ++ radix ++ groupDecimal (right gs) d
- _ -> error "Qty.hs: rendering error"
-
-- * Amounts
-- | Render an Amount. The Format is required so that the commodity
-- can be displayed in the right place.
amount
- :: GroupSpecs
+ :: 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
- -> L.Amount
+ -> Either (L.Amount L.QtyRep) (L.Amount L.Qty)
-> Maybe X.Text
-amount gs maySd maySb (L.Amount qt c) =
- let q = quantity gs qt
- in do
- 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]
+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
@@ -266,14 +233,20 @@
-- * Entries
entry
- :: GroupSpecs
+ :: 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
- -> L.Entry
+ -> Either (L.Entry L.QtyRep) (L.Entry L.Qty)
-> Maybe X.Text
-entry gs sd sb (L.Entry dc a) = do
- amt <- amount gs sd sb a
- let dcTxt = X.pack $ case dc of
+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
@@ -360,19 +333,18 @@
-- * Prices
-price ::
- GroupSpecs
- -> L.PricePoint
+price
+ :: L.PricePoint
-> Maybe X.Text
-price gs pp = let
+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 gs (L.ppSide pp) (L.ppSpaceBetween pp)
- (L.Amount q to)
+ amtTxt <- amount Nothing (L.ppSide pp) (L.ppSpaceBetween pp)
+ (Left (L.Amount q to))
fromTxt <- mayFromTxt
return $
(X.intercalate (X.singleton ' ')
@@ -448,12 +420,16 @@
-- which case eight spaces will be emitted. (This allows the next
-- posting to be indented properly.)
posting
- :: GroupSpecs
+ :: 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 gs pad ent = do
+posting maySpec pad ent = do
let p = L.meta ent
fl <- renMaybe (L.pFlag p) flag
nu <- renMaybe (L.pNumber p) number
@@ -461,14 +437,12 @@
ac <- ledgerAcct (L.pAccount p)
ta <- tags (L.pTags p)
me <- renMaybe (L.pMemo p) (postingMemo pad)
- let mayEn = case L.inferred ent of
- L.Inferred -> Nothing
- L.NotInferred -> (Just . L.entry $ ent)
- en <- renMaybe mayEn (entry gs (L.pSide p) (L.pSpaceBetween p))
+ 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
+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
@@ -498,33 +472,41 @@
-- * Transaction
transaction
- :: GroupSpecs
+ :: 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 gs txn = do
+transaction mayFmt txn = do
tlX <- topLine . fst $ txn
let (p1, p2, ps) = L.tupleEnts . snd $ txn
- p1X <- posting gs True p1
- p2X <- posting gs (not . null $ ps) p2
+ 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 gs) bs ps
+ $ zipWith (posting mayFmt) bs ps
return $ X.concat [tlX, p1X, p2X, psX]
-- * Item
item
- :: GroupSpecs
+ :: 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 gs =
- S.caseS4 (transaction gs)
- (price gs)
+item mayFmt =
+ S.caseS4 (transaction mayFmt)
+ price
comment
(const (Just (X.pack "\n")))
diff --git a/lib/Penny/Liberty.hs b/lib/Penny/Liberty.hs
--- a/lib/Penny/Liberty.hs
+++ b/lib/Penny/Liberty.hs
@@ -82,7 +82,6 @@
import qualified Paths_penny_lib as PPL
#endif
import qualified Data.Version as V
-import qualified System.Exit as Exit
-- | A multiline Text that holds an error message.
type Error = Text
@@ -134,7 +133,8 @@
-> [L.Transaction]
-- ^ The transactions to work on (probably parsed in from Copper)
- -> ([C.Chunk], [(LibertyMeta, L.Posting)])
+ -> ( (L.Amount L.Qty -> X.Text) -> [C.Chunk]
+ , [(LibertyMeta, L.Posting)])
-- ^ Sorted, filtered postings
xactionsToFiltered pdct postFilts srtr
@@ -154,8 +154,15 @@
. processPostFilters postFilters
. addFilteredNum
-mainFilter :: P.LPdct -> [L.Posting] -> ([C.Chunk], [L.Posting])
-mainFilter pdct = E.verboseFilter L.display indentAmt False pdct
+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)]
@@ -365,11 +372,9 @@
f a1 a2 = do
qt <- parseQty a2
parseComparer a1 (flip P.qty qt)
- parseQty a = case parse Pc.quantity "" (pack a) of
- Left e -> Ex.throw $ "could not parse quantity: "
- <> pack a <> " - "
- <> (pack . show $ e)
- Right g -> pure g
+ 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,
@@ -726,36 +731,30 @@
f a1 a2 = do
qt <- parseQty a2
parseComparer a1 (flip PS.qty qt)
- parseQty a = case parse Pc.quantity "" (pack a) of
- Left e -> Ex.throw $ "could not parse quantity: "
- <> pack a <> " - "
- <> (pack . show $ e)
- Right g -> pure g
+ parseQty a = case parse Pc.unquotedQtyRepWithSpaces "" (pack a) of
+ Left _ -> Ex.throw "could not parse quantity"
+ Right g -> pure . L.toQty $ g
--
-- Versions
--
--- | Parses the @--version@ option and returns an IO action that
--- prints it and exits successfully. You supply the version of the
--- executable, as there is no easy way to get that automatically.
+-- | Prints the binary's version and the version of the library, and exits successfully.
version
:: V.Version
- -- ^ Version of binary
- -> OptSpec (IO a)
-version v = C.OptSpec ["version"] [] (C.NoArg f)
- where
- f = do
- pn <- MA.getProgName
- putStrLn $ pn ++ " version " ++ V.showVersion v
+ -> String
+ -- ^ Program name
+ -> String
+version v pn = unlines
+ [ pn ++ " version " ++ V.showVersion v
#ifdef incabal
- putStrLn $ "using version " ++ V.showVersion PPL.version
+ , "using version " ++ V.showVersion PPL.version
#else
- putStrLn $ "using testing version"
+ , "using testing version"
#endif
- ++ " of penny-lib"
- Exit.exitSuccess
+ ++ " of penny-lib"
+ ]
-- | An option for where the user would like to send output.
output :: MA.OptSpec (X.Text -> IO ())
diff --git a/lib/Penny/Lincoln.hs b/lib/Penny/Lincoln.hs
--- a/lib/Penny/Lincoln.hs
+++ b/lib/Penny/Lincoln.hs
@@ -45,8 +45,12 @@
-- Format:
--
-- File LineNo Date Payee Acct DrCr Cmdty Qty
-display :: Posting -> Text
-display p = X.pack $ concat (intersperse " " ls)
+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)
@@ -68,5 +72,6 @@
Debit -> "Dr"
Credit -> "Cr"
cmdty = X.unpack . unCommodity . Q.commodity $ p
- qt = prettyShowQty . Q.qty $ 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
--- a/lib/Penny/Lincoln/Balance.hs
+++ b/lib/Penny/Lincoln/Balance.hs
@@ -32,7 +32,7 @@
-- | Returned by 'balanced'.
data Balanced = Balanced
- | Inferable B.Entry
+ | Inferable (B.Entry B.Qty)
| NotInferable
deriving (Show, Eq)
@@ -45,13 +45,11 @@
Zero -> b
(NonZero col) -> case b of
Balanced -> let
- e = B.Entry dc a
dc = case colDrCr col of
B.Debit -> B.Credit
B.Credit -> B.Debit
q = colQty col
- a = B.Amount q c
- in Inferable e
+ in Inferable (B.Entry dc (B.Amount q c))
_ -> NotInferable
isInferable :: Balanced -> Bool
@@ -59,13 +57,13 @@
isInferable _ = False
-- | Converts an Entry to a Balance.
-entryToBalance :: B.Entry -> 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.qty am))
+ no = NonZero (Column dc (B.toQty . B.qty $ am))
-- | Converts multiple Entries to a Balanced.
-entriesToBalanced :: [B.Entry] -> Balanced
+entriesToBalanced :: B.HasQty q => [B.Entry q] -> Balanced
entriesToBalanced
= balanced
. mconcat
diff --git a/lib/Penny/Lincoln/Bits.hs b/lib/Penny/Lincoln/Bits.hs
--- a/lib/Penny/Lincoln/Bits.hs
+++ b/lib/Penny/Lincoln/Bits.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-- | Essential data types used to make Transactions and Postings.
module Penny.Lincoln.Bits
( module Penny.Lincoln.Bits.Open
@@ -33,17 +31,14 @@
import qualified Penny.Lincoln.Bits.Price as Pr
import qualified Penny.Lincoln.Equivalent as Ev
import Penny.Lincoln.Equivalent ((==~))
-import qualified Data.Binary as B
-import GHC.Generics (Generic)
data PricePoint = PricePoint { dateTime :: DT.DateTime
, price :: Pr.Price
, ppSide :: Maybe O.Side
, ppSpaceBetween :: Maybe O.SpaceBetween
, priceLine :: Maybe O.PriceLine }
- deriving (Eq, Show, Generic)
+ deriving (Eq, Show)
-instance B.Binary PricePoint
-- | PricePoint are equivalent if the dateTime and the Price are
-- equivalent. Other elements of the PricePoint are ignored.
@@ -59,13 +54,11 @@
{ tlCore :: TopLineCore
, tlFileMeta :: Maybe TopLineFileMeta
, tlGlobal :: Maybe O.GlobalTransaction
- } deriving (Eq, Show, Generic)
+ } deriving (Eq, Show)
emptyTopLineData :: DT.DateTime -> TopLineData
emptyTopLineData dt = TopLineData (emptyTopLineCore dt) Nothing Nothing
-instance B.Binary TopLineData
-
-- | Every TopLine has this data.
data TopLineCore = TopLineCore
{ tDateTime :: DT.DateTime
@@ -73,7 +66,7 @@
, tFlag :: Maybe O.Flag
, tPayee :: Maybe O.Payee
, tMemo :: Maybe O.Memo
- } deriving (Eq, Show, Generic)
+ } deriving (Eq, Show)
-- | TopLineCore are equivalent if their dates are equivalent and if
-- everything else is equal.
@@ -96,17 +89,13 @@
emptyTopLineCore :: DT.DateTime -> TopLineCore
emptyTopLineCore dt = TopLineCore dt Nothing Nothing Nothing Nothing
-instance B.Binary TopLineCore
-
-- | 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, Generic)
-
-instance B.Binary TopLineFileMeta
+ } deriving (Eq, Show)
-- | All Postings have this data.
@@ -119,7 +108,7 @@
, pMemo :: Maybe O.Memo
, pSide :: Maybe O.Side
, pSpaceBetween :: Maybe O.SpaceBetween
- } deriving (Eq, Show, Generic)
+ } 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.
@@ -152,22 +141,19 @@
, pSpaceBetween = Nothing
}
-instance B.Binary PostingCore
-
-- | Postings from files have this additional data.
data PostingFileMeta = PostingFileMeta
{ pPostingLine :: O.PostingLine
, pFilePosting :: O.FilePosting
- } deriving (Eq, Show, Generic)
+ } deriving (Eq, Show)
-instance B.Binary PostingFileMeta
-- | All the data that a Posting might have.
data PostingData = PostingData
{ pdCore :: PostingCore
, pdFileMeta :: Maybe PostingFileMeta
, pdGlobal :: Maybe O.GlobalPosting
- } deriving (Eq, Show, Generic)
+ } deriving (Eq, Show)
emptyPostingData :: O.Account -> PostingData
emptyPostingData ac = PostingData
@@ -175,6 +161,4 @@
, pdFileMeta = Nothing
, pdGlobal = Nothing
}
-
-instance B.Binary PostingData
diff --git a/lib/Penny/Lincoln/Bits/DateTime.hs b/lib/Penny/Lincoln/Bits/DateTime.hs
--- a/lib/Penny/Lincoln/Bits/DateTime.hs
+++ b/lib/Penny/Lincoln/Bits/DateTime.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE DeriveGeneric #-}
-
module Penny.Lincoln.Bits.DateTime
( TimeZoneOffset ( offsetToMins )
, minsToOffset
@@ -23,19 +21,13 @@
, showDateTime
) where
-import qualified Control.Monad as M
import qualified Data.Time as T
-import qualified Data.Binary as B
-import Data.Binary (get, put)
-import GHC.Generics (Generic)
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, Generic)
-
-instance B.Binary TimeZoneOffset
+ 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
@@ -52,19 +44,13 @@
noOffset = TimeZoneOffset 0
newtype Hours = Hours { unHours :: Int }
- deriving (Eq, Ord, Show, Generic)
-
-instance B.Binary Hours
+ deriving (Eq, Ord, Show)
newtype Minutes = Minutes { unMinutes :: Int }
- deriving (Eq, Ord, Show, Generic)
-
-instance B.Binary Minutes
+ deriving (Eq, Ord, Show)
newtype Seconds = Seconds { unSeconds :: Int }
- deriving (Eq, Ord, Show, Generic)
-
-instance B.Binary Seconds
+ deriving (Eq, Ord, Show)
-- | succeeds if 0 <= x < 24
intToHours :: Int -> Maybe Hours
@@ -109,12 +95,6 @@
, seconds :: Seconds
, timeZone :: TimeZoneOffset
} deriving (Eq, Ord, Show)
-
-instance B.Binary DateTime where
- get = M.liftM5 DateTime (fmap T.ModifiedJulianDay B.get)
- get get get get
- put (DateTime d h m s t) =
- put (T.toModifiedJulianDay d) >> put h >> put m >> put s >> put t
dateTimeMidnightUTC :: T.Day -> DateTime
dateTimeMidnightUTC d = DateTime d h m s z
diff --git a/lib/Penny/Lincoln/Bits/Open.hs b/lib/Penny/Lincoln/Bits/Open.hs
--- a/lib/Penny/Lincoln/Bits/Open.hs
+++ b/lib/Penny/Lincoln/Bits/Open.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-- | 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
@@ -11,34 +9,26 @@
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as X
-import qualified Data.Text.Encoding as XE
-import GHC.Generics (Generic)
import qualified Penny.Lincoln.Equivalent as Ev
import Penny.Lincoln.Equivalent ((==~))
import qualified Penny.Lincoln.Serial as S
-import qualified Penny.Lincoln.Bits.Qty as Q
-import qualified Data.Binary as B
newtype SubAccount =
SubAccount { unSubAccount :: Text }
deriving (Eq, Ord, Show)
-instance B.Binary SubAccount where
- put = B.put . XE.encodeUtf8 . unSubAccount
- get = fmap (SubAccount . XE.decodeUtf8) B.get
-
newtype Account = Account { unAccount :: [SubAccount] }
- deriving (Eq, Show, Ord, Generic)
-
-instance B.Binary Account
+ deriving (Eq, Show, Ord)
-data Amount = Amount { qty :: Q.Qty
- , commodity :: Commodity }
- deriving (Eq, Show, Ord, Generic)
+data Amount q = Amount
+ { qty :: q
+ , commodity :: Commodity }
+ deriving (Eq, Show, Ord)
-instance B.Binary Amount
+instance Functor Amount where
+ fmap f (Amount q c) = Amount (f q) c
-instance Ev.Equivalent Amount where
+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) =
@@ -48,27 +38,24 @@
Commodity { unCommodity :: Text }
deriving (Eq, Ord, Show)
-instance B.Binary Commodity where
- get = fmap (Commodity . XE.decodeUtf8) B.get
- put = B.put . XE.encodeUtf8 . unCommodity
+data DrCr = Debit | Credit deriving (Eq, Show, Ord)
-data DrCr = Debit | Credit deriving (Eq, Show, Ord, Generic)
-instance B.Binary DrCr
-
-- | Debit returns Credit; Credit returns Debit
opposite :: DrCr -> DrCr
opposite d = case d of
Debit -> Credit
Credit -> Debit
-data Entry = Entry { drCr :: DrCr
- , amount :: Amount }
- deriving (Eq, Show, Ord, Generic)
+data Entry q = Entry
+ { drCr :: DrCr
+ , amount :: Amount q }
+ deriving (Eq, Show, Ord)
-instance B.Binary Entry
+instance Functor Entry where
+ fmap f (Entry d a) = Entry d (fmap f a)
-instance Ev.Equivalent Entry where
+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) =
@@ -77,44 +64,23 @@
newtype Flag = Flag { unFlag :: Text }
deriving (Eq, Show, Ord)
-instance B.Binary Flag where
- get = fmap (Flag . XE.decodeUtf8) B.get
- put = B.put . XE.encodeUtf8 . unFlag
-
-- | 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)
-instance B.Binary Memo where
- get = fmap (Memo . map XE.decodeUtf8) B.get
- put = B.put . map XE.encodeUtf8 . unMemo
-
newtype Number = Number { unNumber :: Text }
deriving (Eq, Show, Ord)
-instance B.Binary Number where
- get = fmap (Number . XE.decodeUtf8) B.get
- put = B.put . XE.encodeUtf8 . unNumber
-
-
newtype Payee = Payee { unPayee :: Text }
deriving (Eq, Show, Ord)
-instance B.Binary Payee where
- get = fmap (Payee . XE.decodeUtf8) B.get
- put = B.put . XE.encodeUtf8 . unPayee
-
newtype Tag = Tag { unTag :: Text }
deriving (Eq, Show, Ord)
-instance B.Binary Tag where
- get = fmap (Tag . XE.decodeUtf8) B.get
- put = B.put . XE.encodeUtf8 . unTag
-
newtype Tags = Tags { unTags :: [Tag] }
- deriving (Eq, Show, Ord, Generic)
+ deriving (Eq, Show, Ord)
-- | Tags are equivalent if they have the same tags (even if in a
-- different order).
@@ -123,22 +89,16 @@
compareEv (Tags t1) (Tags t2) =
compare (sort t1) (sort t2)
-instance B.Binary Tags
-
-- Metadata
-- | The line number that the TopLine starts on (excluding the memo
-- accompanying the TopLine).
newtype TopLineLine = TopLineLine { unTopLineLine :: Int }
- deriving (Eq, Show, Generic)
-
-instance B.Binary TopLineLine
+ deriving (Eq, Show)
-- | The line number that the memo accompanying the TopLine starts on.
newtype TopMemoLine = TopMemoLine { unTopMemoLine :: Int }
- deriving (Eq, Show, Generic)
-
-instance B.Binary TopMemoLine
+ 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
@@ -146,69 +106,57 @@
data Side
= CommodityOnLeft
| CommodityOnRight
- deriving (Eq, Show, Ord, Generic)
+ deriving (Eq, Show, Ord)
-instance B.Binary Side
+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, Generic)
+ deriving (Eq, Show, Ord)
-instance B.Binary SpaceBetween
+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)
-instance B.Binary Filename where
- get = fmap (Filename . XE.decodeUtf8) B.get
- put = B.put . XE.encodeUtf8 . unFilename
-
-
-- | The line number on which a price appears.
newtype PriceLine = PriceLine { unPriceLine :: Int }
- deriving (Eq, Show, Generic)
-
-instance B.Binary PriceLine
+ deriving (Eq, Show)
-- | The line number on which a posting appears.
newtype PostingLine = PostingLine { unPostingLine :: Int }
- deriving (Eq, Show, Generic)
-
-instance B.Binary PostingLine
+ 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, Generic)
-
-instance B.Binary GlobalPosting
+ deriving (Eq, Show)
-- | The postings in each file are numbered in order.
newtype FilePosting =
FilePosting { unFilePosting :: S.Serial }
- deriving (Eq, Show, Generic)
-
-instance B.Binary FilePosting
+ 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, Generic)
-
-instance B.Binary GlobalTransaction
+ deriving (Eq, Show)
-- | The transactions in each file are numbered in order.
newtype FileTransaction =
FileTransaction { unFileTransaction :: S.Serial }
- deriving (Eq, Show, Generic)
-
-instance B.Binary FileTransaction
+ deriving (Eq, Show)
diff --git a/lib/Penny/Lincoln/Bits/Price.hs b/lib/Penny/Lincoln/Bits/Price.hs
--- a/lib/Penny/Lincoln/Bits/Price.hs
+++ b/lib/Penny/Lincoln/Bits/Price.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}
-
module Penny.Lincoln.Bits.Price (
From ( From, unFrom )
, To ( To, unTo )
@@ -12,35 +10,26 @@
import qualified Penny.Lincoln.Equivalent as Ev
import Penny.Lincoln.Equivalent ((==~))
import qualified Penny.Lincoln.Bits.Open as O
-import Penny.Lincoln.Bits.Qty (Qty)
-import GHC.Generics (Generic)
-import qualified Data.Binary as B
+import Penny.Lincoln.Bits.Qty (QtyRep)
-newtype From = From { unFrom :: O.Commodity }
- deriving (Eq, Ord, Show, Generic)
-instance B.Binary From
+newtype From = From { unFrom :: O.Commodity }
+ deriving (Eq, Ord, Show)
newtype To = To { unTo :: O.Commodity }
- deriving (Eq, Ord, Show, Generic)
-
-instance B.Binary To
+ deriving (Eq, Ord, Show)
-newtype CountPerUnit = CountPerUnit { unCountPerUnit :: Qty }
- deriving (Eq, Ord, Show, Generic)
+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
-instance B.Binary CountPerUnit
-
data Price = Price { from :: From
, to :: To
, countPerUnit :: CountPerUnit }
- deriving (Eq, Ord, Show, Generic)
-
-instance B.Binary Price
+ deriving (Eq, Ord, Show)
-- | Two Price are equivalent if the From and To are equal and the
-- CountPerUnit is equivalent.
diff --git a/lib/Penny/Lincoln/Bits/Qty.hs b/lib/Penny/Lincoln/Bits/Qty.hs
--- a/lib/Penny/Lincoln/Bits/Qty.hs
+++ b/lib/Penny/Lincoln/Bits/Qty.hs
@@ -1,17 +1,53 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# 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
- ( Qty
- , NumberStr(..)
- , toQty
- , mantissa
+ (
+ -- * 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
- , prettyShowQty
, compareQty
, newQty
- , Mantissa
+ , Signif
, Places
, add
, mult
@@ -25,46 +61,466 @@
, qtyOne
) where
+-- # Imports
+
+import Control.Applicative ((<|>))
import qualified Control.Monad.Exception.Synchronous as Ex
-import qualified Data.Binary as B
-import GHC.Generics (Generic)
-import Data.List (genericLength, genericReplicate, genericSplitAt, sortBy)
-import Data.Ord (comparing)
+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 NumberStr =
- Whole String
- -- ^ A whole number only. No radix point.
- | WholeRad String
- -- ^ A whole number and a radix point, but nothing after the radix
- -- point.
- | WholeRadFrac String String
- -- ^ A whole number and something after the radix point.
- | RadFrac String
- -- ^ A radix point and a fractional value after it, but nothing
- -- before the radix point.
- deriving Show
+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)
--- | Converts strings to Qty. Fails if any of the strings have
--- non-digits, or if any are negative, or if the result is not greater
--- than zero, or if the strings are empty.
-toQty :: NumberStr -> Maybe Qty
-toQty ns = case ns of
- Whole s -> fmap (\m -> Qty m 0) (readInteger s)
- WholeRad s -> fmap (\m -> Qty m 0) (readInteger s)
- WholeRadFrac w f -> fromWholeRadFrac w f
- RadFrac f -> fromWholeRadFrac "0" f
+-- | 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
- fromWholeRadFrac w f =
- fmap (\m -> Qty m (genericLength f)) (readInteger (w ++ f))
+ 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" }
--- | Reads non-negative integers only.
-readInteger :: String -> Maybe Integer
-readInteger s = case reads s of
- (i, ""):[] -> if i < 0 then Nothing else Just i
- _ -> Nothing
+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
@@ -82,31 +538,14 @@
-- /WARNING/ - before doing comparisons or equality tests
--
-- The Eq instance is derived. Therefore q1 == q2 only if q1 and q2
--- have both the same mantissa and the same exponent. You may instead
+-- 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 mantissa and of the
+-- 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 { mantissa :: !Integer
+data Qty = Qty { signif :: !Integer
, places :: !Integer
- } deriving (Eq, Generic, Show, Ord)
-
--- | Shows a quantity, nicely formatted after accounting for both the
--- mantissa and decimal places, e.g. @0.232@ or @232.12@ or whatever.
-prettyShowQty :: Qty -> String
-prettyShowQty q =
- let man = show . mantissa $ q
- e = places q
- len = genericLength man
- small = "0." ++ ((genericReplicate (e - len) '0') ++ man)
- in case compare e len of
- GT -> small
- EQ -> small
- LT ->
- let (b, end) = genericSplitAt (len - e) man
- in if e == 0
- then man
- else b ++ ['.'] ++ end
+ } deriving (Eq, Show, Ord)
instance Ev.Equivalent Qty where
equivalent x y = x' == y'
@@ -116,30 +555,25 @@
where
(x', y') = equalizeExponents x y
-instance B.Binary Qty
-
-type Mantissa = Integer
+type Signif = Integer
type Places = Integer
--- | Mantissa 1, exponent 0
+-- | Significand 1, exponent 0
qtyOne :: Qty
qtyOne = Qty 1 0
-
-
-newQty :: Mantissa -> Places -> Maybe Qty
+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 (mantissa q1') (mantissa q2')
+compareQty q1 q2 = compare (signif q1') (signif q2')
where
(q1', q2') = equalizeExponents q1 q2
@@ -183,7 +617,7 @@
difference :: Qty -> Qty -> Difference
difference x y =
let (x', y') = equalizeExponents x y
- (mx, my) = (mantissa x', mantissa 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'))
@@ -208,7 +642,7 @@
-- Adjust all exponents, both on the amount to be allocated and on all
-- the votes, so that the exponents are all equal.
--
--- Allocate the mantissas.
+-- Allocate the significands.
--
-- Return the quantities with the original exponents.
@@ -236,8 +670,8 @@
allocate' tot ls =
let ((tot':ls'), e) = sameExponent (tot:ls)
(moreE, (_, ss)) =
- multRemainderAllResultsAtLeast1 (mantissa tot')
- (map mantissa ls')
+ multRemainderAllResultsAtLeast1 (signif tot')
+ (map signif ls')
totE = e + moreE
in map (\m -> Qty m totE) ss
diff --git a/lib/Penny/Lincoln/Ents.hs b/lib/Penny/Lincoln/Ents.hs
--- a/lib/Penny/Lincoln/Ents.hs
+++ b/lib/Penny/Lincoln/Ents.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveGeneric, DeriveFunctor #-}
+{-# LANGUAGE DeriveFunctor #-}
-- | Containers for entries.
--
@@ -29,11 +29,10 @@
module Penny.Lincoln.Ents
( -- * Ent
- Inferred(..)
- , Ent
+ Ent
, entry
- , inferred
, meta
+ , inferred
-- * Ents
, Ents
@@ -56,8 +55,6 @@
import Control.Applicative
import Control.Arrow (second)
-import Data.Binary (Binary)
-import GHC.Generics (Generic)
import qualified Penny.Lincoln.Bits as B
import qualified Penny.Lincoln.Balance as Bal
import Control.Monad (guard)
@@ -69,41 +66,36 @@
import qualified Data.Traversable as Tr
import qualified Data.Foldable as Fdbl
--- | An Ent is inferred if the user did not supply an entry for it and
--- Penny was able to infer the correct entry. Otherwise it is not
--- inferred.
-data Inferred = Inferred | NotInferred
- deriving (Eq, Ord, Show, Generic)
-instance Binary Inferred
-
-- | Information about an entry, along with whether it is inferred and
-- its metadata.
data Ent m = Ent
- { entry :: B.Entry
- -- ^ The entry from an Ent
- , inferred :: Inferred
- -- ^ Whether the entry was inferred
+ { 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
- } deriving (Eq, Ord, Show, Generic)
+ , 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) =
+ 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 i m) = Ent e i (f m)
-
-instance Binary m => Binary (Ent m)
+ fmap f (Ent e m i) = Ent e (f m) i
newtype Ents m = Ents { unEnts :: [Ent m] }
- deriving (Eq, Ord, Show, Generic, Functor)
+ deriving (Eq, Ord, Show, Functor)
-- | Ents are equivalent if the content Ents of each are
-- equivalent. The order of the ents is insignificant.
@@ -139,10 +131,10 @@
-- 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 <*> pure i <*> f en
+ f' en@(Ent e _ i) = Ent <$> pure e <*> f en <*> pure i
seqEnt :: Applicative f => Ent (f a) -> f (Ent a)
-seqEnt (Ent e i m) = Ent <$> pure e <*> pure i <*> m
+seqEnt (Ent e m i) = Ent <$> pure e <*> m <*> pure i
-- | Every Ents alwas contains at least two ents, and possibly
-- additional ones.
@@ -151,8 +143,6 @@
t1:t2:ts -> (t1, t2, ts)
_ -> error "tupleEnts: ents does not have two ents"
-instance Binary m => Binary (Ents m)
-
-- | 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
@@ -216,23 +206,27 @@
-- and this function will infer the remaining Entry. This function
-- fails if it cannot create a balanced Ents.
ents
- :: [(Maybe B.Entry, m)]
+ :: [(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 . catMaybes . map fst $ ls of
+ 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 e Inferred mt
- Just en -> Ent en NotInferred mt
+ 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 NotInferred mt
+ Just en -> Just $ Ent en mt False
in fmap Ents $ mapM makeEnt ls
@@ -245,21 +239,23 @@
-- ^ Commodity for all postings
-> B.DrCr
-- ^ DrCr for all non-inferred postings
- -> (B.Qty, m)
+ -> (Either B.QtyRep B.Qty, m)
-- ^ Non-inferred posting 1
- -> [(B.Qty, m)]
+ -> [(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 q1 . map fst $ nonInfs
+ 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
- makePstg (q, m) = Ent (B.Entry dc (B.Amount q com))
- NotInferred m
- lastPstg = Ent (B.Entry (B.opposite dc) (B.Amount tot com))
- Inferred lastMeta
+ 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
--- a/lib/Penny/Lincoln/Equivalent.hs
+++ b/lib/Penny/Lincoln/Equivalent.hs
@@ -15,7 +15,36 @@
(==~) = 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/PriceDb.hs b/lib/Penny/Lincoln/PriceDb.hs
--- a/lib/Penny/Lincoln/PriceDb.hs
+++ b/lib/Penny/Lincoln/PriceDb.hs
@@ -85,14 +85,15 @@
-- fail and throw PriceDbError. Internally uses 'getPrice', so read its
-- documentation for details on how price lookup works.
convertAsOf ::
- PriceDb
+ B.HasQty q
+ => PriceDb
-> B.DateTime
-> B.To
- -> B.Amount
+ -> B.Amount q
-> Ex.Exceptional PriceDbError B.Qty
convertAsOf db dt to (B.Amount qt fr)
- | fr == B.unTo to = return qt
+ | 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 cpu qt
+ 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
--- a/lib/Penny/Lincoln/Queries.hs
+++ b/lib/Penny/Lincoln/Queries.hs
@@ -52,23 +52,27 @@
tags :: E.Posting -> B.Tags
tags = B.pTags . B.pdCore . E.meta . E.headEnt . snd . E.unPosting
-entry :: E.Posting -> B.Entry
+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 = entryToBalance . entry
+balance = either entryToBalance entryToBalance . entry
drCr :: E.Posting -> B.DrCr
-drCr = B.drCr . entry
+drCr = either B.drCr B.drCr . entry
-amount :: E.Posting -> B.Amount
-amount = B.amount . 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 = B.qty . amount
+qty = either B.toQty B.toQty . eiQty
commodity :: E.Posting -> B.Commodity
-commodity = B.commodity . amount
+commodity = either B.commodity B.commodity . amount
topMemoLine :: E.Posting -> Maybe B.TopMemoLine
topMemoLine p = (B.tlFileMeta . fst . E.unPosting $ p) >>= B.tTopMemoLine
diff --git a/lib/Penny/Lincoln/Queries/Siblings.hs b/lib/Penny/Lincoln/Queries/Siblings.hs
--- a/lib/Penny/Lincoln/Queries/Siblings.hs
+++ b/lib/Penny/Lincoln/Queries/Siblings.hs
@@ -59,23 +59,23 @@
tags :: E.Posting -> [B.Tags]
tags = sibs (B.pTags . B.pdCore . E.meta)
-entry :: E.Posting -> [B.Entry]
+entry :: E.Posting -> [Either (B.Entry B.QtyRep) (B.Entry B.Qty)]
entry = sibs E.entry
balance :: E.Posting -> [Balance]
-balance = map entryToBalance . entry
+balance = map (either entryToBalance entryToBalance) . entry
drCr :: E.Posting -> [B.DrCr]
-drCr = map B.drCr . entry
+drCr = map (either B.drCr B.drCr) . entry
-amount :: E.Posting -> [B.Amount]
-amount = map B.amount . 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 B.qty . amount
+qty = map (either (B.toQty . B.qty) (B.toQty . B.qty)) . amount
commodity :: E.Posting -> [B.Commodity]
-commodity = map B.commodity . amount
+commodity = map (either B.commodity B.commodity) . amount
postingLine :: E.Posting -> [Maybe B.PostingLine]
postingLine = sibs (fmap B.pPostingLine . B.pdFileMeta . E.meta)
diff --git a/lib/Penny/Wheat.hs b/lib/Penny/Wheat.hs
--- a/lib/Penny/Wheat.hs
+++ b/lib/Penny/Wheat.hs
@@ -105,6 +105,9 @@
-- ^ Tests may use this date and time as they wish; see
-- 'tests'. Typically you will set this to the current instant.
+ , formatQty :: [Cop.LedgerItem] -> L.Amount L.Qty -> X.Text
+ -- ^ How to format quantities
+
}
parseBaseTime :: String -> Ex.Exceptional MA.InputError Time.UTCTime
@@ -143,14 +146,10 @@
-- corresponding to the ledger files provided on the command line.
parseArgs :: V.Version -> WheatConf -> IO (WheatConf, [String])
parseArgs ver c = do
- parsed <- MA.simpleWithHelp (help c) MA.Intersperse
- (fmap Left (Ly.version ver) : (map (fmap (Right . Left)) allOpts))
- (return . Right . Right)
- let (showVers, optsAndArgs) = partitionEithers parsed
- case showVers of
- [] -> return ()
- x:_ -> x
- let (opts, args) = partitionEithers optsAndArgs
+ parsed <- MA.simpleHelpVersion (help c) (Ly.version ver)
+ (map (fmap Right) allOpts) MA.Intersperse
+ (return . Left)
+ let (args, opts) = partitionEithers parsed
fn = foldl (flip (.)) id opts
c' = fn c
return (c', args)
@@ -169,12 +168,14 @@
rt <- S.runtime
(conf, args) <- parseArgs ver (getWc rt)
term <- Rb.smartTermFromEnv (colorToFile conf) IO.stdout
- pstgs <- getItems args
+ items <- Cop.open args
+ let pstgs = getItems items
+ formatter = formatQty conf items
let tsts = filter ((testPred conf) . TT.testName)
. map ($ (L.toUTC . S.currentTime $ rt))
. tests
$ conf
- bs <- mapM (runTest conf pstgs term) tsts
+ bs <- mapM (runTest formatter conf pstgs term) tsts
if and bs
then Exit.exitSuccess
else Exit.exitFailure
@@ -183,25 +184,26 @@
-- set and if the test failed. Otherwise, returns whether the test
-- succeeded or failed.
runTest
- :: WheatConf
+ :: (L.Amount L.Qty -> X.Text)
+ -> WheatConf
-> [L.Posting]
-> Rb.Term
-> TT.Test L.Posting
-> IO Bool
-runTest c ps term test = do
+runTest fmt c ps term test = do
let rslt = TT.evalTest test ps
- cks = TT.showResult (indentAmt c) L.display (verbosity c) rslt
+ cks = TT.showResult (indentAmt c) (L.display fmt)
+ (verbosity c) rslt
Rb.putChunks term cks
if stopOnFail c && not (TT.resultPass rslt)
then Exit.exitFailure
else return (TT.resultPass rslt)
-getItems :: [String] -> IO [L.Posting]
-getItems ss = fmap f $ Cop.open ss
- where
- f = concatMap L.transactionToPostings
- . mapMaybe ( let cn = const Nothing
- in Su.caseS4 Just cn cn cn)
+getItems :: [Cop.LedgerItem] -> [L.Posting]
+getItems
+ = concatMap L.transactionToPostings
+ . mapMaybe ( let cn = const Nothing
+ in Su.caseS4 Just cn cn cn)
--
-- Tests
diff --git a/lib/Penny/Zinc.hs b/lib/Penny/Zinc.hs
--- a/lib/Penny/Zinc.hs
+++ b/lib/Penny/Zinc.hs
@@ -23,7 +23,6 @@
import qualified Penny.Steel.Sums as Su
import Control.Applicative ((<*>), pure, (<$))
-import Control.Monad (join)
import qualified Control.Monad.Trans.State as St
import qualified Control.Monad.Exception.Synchronous as Ex
import Data.Char (toUpper, toLower)
@@ -32,7 +31,7 @@
import Data.Maybe (mapMaybe, catMaybes, fromMaybe)
import Data.Monoid (mappend, mconcat, (<>))
import Data.Ord (comparing)
-import Data.Text (Text, pack)
+import Data.Text (Text, pack, unpack)
import Data.Version (Version)
import qualified Data.Text.IO as TIO
import qualified System.Console.MultiArg as MA
@@ -51,8 +50,15 @@
runZinc ver df rt rs = do
let ord = sortPairsToFn . sorter $ df
hlp = helpText df rt rs
- join $ MA.modesWithHelp hlp (allOpts ver (S.currentTime rt) df)
- (processGlobal rt ord df rs)
+ globals = MA.optsHelpVersion hlp (Ly.version ver)
+ (allOpts (S.currentTime rt) df)
+ ei <- MA.modesIO globals (processGlobal rt ord df rs)
+ case ei of
+ Left h -> do
+ pn <- MA.getProgName
+ putStr (h pn)
+ Exit.exitSuccess
+ Right act -> act
-- | Whether to use color when standard output is not a terminal.
@@ -94,6 +100,7 @@
-- > [(Date, Ascending), (Payee, Ascending)]
, exprDesc :: X.ExprDesc
+ , formatQty :: [C.LedgerItem] -> L.Amount L.Qty -> Text
}
sortPairToFn :: (SortField, P.SortOrder) -> Orderer
@@ -164,7 +171,6 @@
| RExprDesc X.ExprDesc
| RShowExpression
| RVerboseFilter
- | RShowVersion (IO ())
getPostFilters
:: [OptResult]
@@ -201,13 +207,6 @@
then return i
else fmap mconcat . sequence $ exSpecs
-getShowVersion :: [OptResult] -> Maybe (IO ())
-getShowVersion ls = case mapMaybe f ls of
- [] -> Nothing
- xs -> Just $ last xs
- where
- f o = case o of { RShowVersion i -> Just i; _ -> Nothing }
-
type Factory = M.CaseSensitive
-> Text -> Ex.Exceptional Text M.Matcher
@@ -249,8 +248,8 @@
in fmap (\xs -> (xs, st')) . sequence . catMaybes $ ls
-allOpts :: Version -> L.DateTime -> Defaults -> [MA.OptSpec OptResult]
-allOpts ver dt df =
+allOpts :: L.DateTime -> Defaults -> [MA.OptSpec OptResult]
+allOpts dt df =
map (fmap ROperand) (Ly.operandSpecs dt)
++ [fmap RPostFilter . fst $ Ly.postFilterSpecs]
++ [fmap RPostFilter . snd $ Ly.postFilterSpecs]
@@ -264,7 +263,6 @@
++ map (fmap RExprDesc) Ly.exprDesc
++ [ RShowExpression <$ Ly.showExpression
, RVerboseFilter <$ Ly.verboseFilter
- , fmap RShowVersion (Ly.version ver)
]
optColorToFile :: MA.OptSpec OptResult
@@ -324,9 +322,12 @@
-- subsequent parses of the command line.
, foSorterFilterer :: [L.Transaction]
- -> ([R.Chunk], [(Ly.LibertyMeta, L.Posting)])
- -- ^ Applied to a list of Transaction, will sort and filter
- -- the transactions and assign them LibertyMeta.
+ -> ( (L.Amount L.Qty -> Text) -> [R.Chunk]
+ , [(Ly.LibertyMeta, L.Posting)])
+ -- ^ Applied to a list of Transaction, will sort and filter the
+ -- transactions and assign them LibertyMeta. Also, returns a
+ -- function that, when applied to a function that will format
+ -- quantities, returns a verbose description of what was filtered.
, foTextSpecs :: Maybe E.Changers
@@ -343,43 +344,40 @@
-> Defaults
-> [I.Report]
-> [OptResult]
- -> Either (a -> IO ()) [MA.Mode (IO ())]
+ -> Ex.Exceptional String
+ (Either a [MA.Mode (MA.ProgName -> String) (IO ())])
processGlobal rt srt df rpts os
= case processFiltOpts srt df os of
- Ex.Exception s -> Left $ (const $ handleTextError s)
- Ex.Success mayFo -> case mayFo of
- Left i -> Left . const $ i
- Right fo -> Right $ map (makeMode rt fo) rpts
+ Ex.Exception s -> Ex.throw s
+ Ex.Success fo ->
+ return . Right $ map (makeMode (formatQty df) rt fo) rpts
processFiltOpts
:: Orderer
-> Defaults
-> [OptResult]
- -> Ex.Exceptional Error (Either (IO ()) FilterOpts)
- -- ^ Left if the user asked to see the version; Right with the
- -- FilterOpts otherwise.
-processFiltOpts ord df os = case getShowVersion os of
- Just i -> return $ Left i
- Nothing -> do
- postFilts <- getPostFilters os
- sortSpec <- getSortSpec ord os
- (toks, (rs, rf)) <- makeTokens df os
- let ctf = getColorToFile df os
- sch = getScheme df os
- expDsc = getExprDesc df os
- showExpr = getShowExpression os
- verbFilt = getVerboseFilter os
- pdct <- Ly.parsePredicate expDsc toks
- let sf = Ly.xactionsToFiltered pdct postFilts sortSpec
- return . Right $ FilterOpts rf rs sf sch
- ctf expDsc pdct showExpr verbFilt
+ -> Ex.Exceptional String FilterOpts
+processFiltOpts ord df os = Ex.mapException unpack $ do
+ postFilts <- getPostFilters os
+ sortSpec <- getSortSpec ord os
+ (toks, (rs, rf)) <- makeTokens df os
+ let ctf = getColorToFile df os
+ sch = getScheme df os
+ expDsc = getExprDesc df os
+ showExpr = getShowExpression os
+ verbFilt = getVerboseFilter os
+ pdct <- Ly.parsePredicate expDsc toks
+ let sf ls = Ly.xactionsToFiltered pdct postFilts sortSpec ls
+ return $ FilterOpts rf rs sf sch
+ ctf expDsc pdct showExpr verbFilt
makeMode
- :: S.Runtime
+ :: ([C.LedgerItem] -> L.Amount L.Qty -> Text)
+ -> S.Runtime
-> FilterOpts
-> I.Report
- -> MA.Mode (IO ())
-makeMode rt fo r = fmap makeIO mode
+ -> MA.Mode (MA.ProgName -> String) (IO ())
+makeMode mkFmt rt fo r = fmap makeIO mode
where
mode = snd (r rt) (foResultSensitive fo) (foResultFactory fo)
(fromMaybe Schemes.plainLabels . foTextSpecs $ fo)
@@ -387,16 +385,18 @@
makeIO parseResult = do
(posArgs, printRpt) <-
Ex.switch handleTextError return parseResult
- (txns, pps) <- fmap splitLedger $ C.open posArgs
- let term = if unColorToFile (foColorToFile fo)
+ items <- C.open posArgs
+ let fmt = mkFmt items
+ (txns, pps) = splitLedger items
+ term = if unColorToFile (foColorToFile fo)
then S.termFromEnv rt
else S.autoTerm rt
printer = R.putChunks term
- verbFiltChunks = fst . foSorterFilterer fo $ txns
+ verbFiltChunks = (fst . foSorterFilterer fo $ txns) fmt
showFilterExpression printer (foShowExpression fo) (foPredicate fo)
showVerboseFilter printer (foVerboseFilter fo) verbFiltChunks
Ex.switch handleTextError (R.putChunks term)
- $ printRpt txns pps
+ $ printRpt fmt txns pps
handleTextError :: Text -> IO a
diff --git a/penny-lib.cabal b/penny-lib.cabal
--- a/penny-lib.cabal
+++ b/penny-lib.cabal
@@ -1,5 +1,5 @@
Name: penny-lib
-Version: 0.20.0.0
+Version: 0.21.0.0
Cabal-version: >=1.8
Build-Type: Simple
License: BSD3
@@ -12,25 +12,10 @@
Category: Console, Finance
License-File: LICENSE
-synopsis: Extensible double-entry accounting system - library
-
-description: Penny is a double-entry accounting system. It is inspired
- by, but incompatible with, John Wiegley's Ledger, which is available
- at .
-
- .
-
- This package is a library. To start using Penny you will want to
- install the penny-bin package, which has the executable programs.
- More about the penny-bin package, along with a full sales pitch
- for Penny and how to get started, is at
- . It may be installed
- with "cabal install penny-bin".
-
- .
+synopsis: Deprecated - use penny package instead
- The Penny library is a full system to work with double-entry
- accounting transactions and postings and to make reports with them.
+description:
+ This package is now deprecated. Use the penny package instead.
source-repository head
type: git
@@ -46,7 +31,7 @@
, containers ==0.5.*
, explicit-exception ==0.1.*
, matchers ==0.6.*
- , multiarg ==0.16.*
+ , multiarg ==0.18.*
, ofx ==0.2.*
, old-locale ==1.0.*
, parsec >= 3.1.2 && < 3.2
@@ -157,7 +142,10 @@
-- Be sure the build-depends are listed within the if block;
-- otherwise, cabal install will always include these
- -- build-dependencies in any build, even non-test builds.
+ -- build-dependencies in any build, even non-test builds. However,
+ -- you still have to list all the build-depends--the library
+ -- build-depends are included for dependency resolving purposes but
+ -- not for building purposes.
-- Test dependencies. test-framework has issues with newer versions,
-- see
@@ -167,6 +155,27 @@
QuickCheck ==2.5.*
, random-shuffle ==0.0.4
+ , base ==4.*
+ , action-permutations ==0.0.0.0
+ , binary ==0.7.*
+ , bytestring ==0.10.*
+ , cereal ==0.3.*
+ , containers ==0.5.*
+ , explicit-exception ==0.1.*
+ , matchers ==0.6.*
+ , multiarg ==0.18.*
+ , ofx ==0.2.*
+ , old-locale ==1.0.*
+ , parsec >= 3.1.2 && < 3.2
+ , prednote == 0.14.*
+ , pretty-show ==1.5.*
+ , rainbow ==0.4.*
+ , semigroups ==0.9.*
+ , split ==0.2.*
+ , text ==0.11.*
+ , time ==1.4.*
+ , transformers == 0.3.*
+
else
buildable: False
@@ -180,6 +189,29 @@
build-depends:
QuickCheck ==2.5.*
, random-shuffle ==0.0.4
+ , random ==1.0.*
+
+ , base ==4.*
+ , action-permutations ==0.0.0.0
+ , binary ==0.7.*
+ , bytestring ==0.10.*
+ , cereal ==0.3.*
+ , containers ==0.5.*
+ , explicit-exception ==0.1.*
+ , matchers ==0.6.*
+ , multiarg ==0.18.*
+ , ofx ==0.2.*
+ , old-locale ==1.0.*
+ , parsec >= 3.1.2 && < 3.2
+ , prednote == 0.14.*
+ , pretty-show ==1.5.*
+ , rainbow ==0.4.*
+ , semigroups ==0.9.*
+ , split ==0.2.*
+ , text ==0.11.*
+ , time ==1.4.*
+ , transformers == 0.3.*
+
else
buildable: False
diff --git a/tests/penny-gibberish.hs b/tests/penny-gibberish.hs
--- a/tests/penny-gibberish.hs
+++ b/tests/penny-gibberish.hs
@@ -23,26 +23,15 @@
, " -c, --count INT"
, " Number of items (transactions, comments, prices, and"
, " blank lines, total) to output. (default: 100)"
- , " -l, --left GROUP_SPEC"
- , " Group left of the decimal point (default: none)"
- , " -r, --right GROUP_SPEC"
- , " Group right of the decimal point (default: none)"
- , " where GROUP_SPEC is:"
- , " none - no digit grouping"
- , " large - group if greater than 9,999 left of decimal,"
- , " or more than 4 decimal places right of decimal"
- , " all - group whenever there are at least 4 places"
]
data Opts = Opts
{ optSize :: Int
, optCount :: Int
- , optLeft :: R.GroupSpec
- , optRight :: R.GroupSpec
} deriving Show
defaultOpts :: Opts
-defaultOpts = Opts 5 100 R.NoGrouping R.NoGrouping
+defaultOpts = Opts 5 100
options :: [MA.OptSpec (Opts -> Opts)]
options =
@@ -57,21 +46,8 @@
if i < 1
then Ex.throw (MA.ErrorMsg "non-positive count parameter")
else return (\os -> os { optCount = i })
-
- , MA.OptSpec ["left"] "l" . MA.ChoiceArg
- . map (\(str, spec) -> (str, \os -> os { optLeft = spec }))
- $ groupSpecs
-
- , MA.OptSpec ["right"] "r" . MA.ChoiceArg
- . map (\(str, spec) -> (str, \os -> os { optRight = spec }))
- $ groupSpecs
]
-groupSpecs :: [(String, R.GroupSpec)]
-groupSpecs = [ ("none", R.NoGrouping)
- , ("large", R.GroupLarge)
- , ("all", R.GroupAll ) ]
-
posArg :: a -> Ex.Exceptional MA.InputError b
posArg _ = Ex.throw (MA.ErrorMsg "no non-option arguments accepted")
@@ -81,15 +57,14 @@
main :: IO ()
main = do
pn <- MA.getProgName
- os <- fmap parse $ MA.simpleWithHelp help MA.Intersperse options
+ os <- fmap parse $ MA.simpleHelp help options MA.Intersperse
posArg
gen <- Rand.getStdGen
let is = (\g -> G.unGen g gen (optSize os))
. fmap (map fst)
. replicateM (optCount os)
$ P.item
- gs = R.GroupSpecs (optLeft os) (optRight os)
- x = mapM (R.item gs) is
+ x = mapM (R.item Nothing) is
case x of
Nothing -> do
IO.hPutStrLn IO.stderr $ pn ++ ": error: could not render ledger."
diff --git a/tests/penny-test.hs b/tests/penny-test.hs
--- a/tests/penny-test.hs
+++ b/tests/penny-test.hs
@@ -34,8 +34,8 @@
main :: IO ()
main = do
- opts <- MA.simpleWithHelp help MA.Intersperse
- options
+ opts <- MA.simpleHelp help options
+ MA.Intersperse
( const . Ex.Exception . MA.ErrorMsg
$ "this command does not accept positional arguments")
let args = foldl (flip (.)) id opts Q.stdArgs