diff --git a/Hledger/Data/Account.hs b/Hledger/Data/Account.hs --- a/Hledger/Data/Account.hs +++ b/Hledger/Data/Account.hs @@ -26,7 +26,7 @@ instance Show Account where show Account{..} = printf "Account %s (boring:%s, ebalance:%s, ibalance:%s)" aname - (if aboring then "y" else "n") + (if aboring then "y" else "n" :: String) (showMixedAmount aebalance) (showMixedAmount aibalance) @@ -159,7 +159,7 @@ (aname a) (showMixedAmount $ aebalance a) (showMixedAmount $ aibalance a) - (if aboring a then "b" else " ") + (if aboring a then "b" else " " :: String) tests_Hledger_Data_Account = TestList [ diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -51,6 +51,7 @@ -- ** arithmetic costOfAmount, divideAmount, + sumAmounts, -- ** rendering showAmount, showAmountDebug, @@ -62,6 +63,7 @@ missingmixedamt, amounts, normaliseMixedAmountPreservingFirstPrice, + normaliseMixedAmountPreservingPrices, canonicaliseMixedAmountCommodity, mixedAmountWithCommodity, setMixedAmountPrecision, @@ -77,6 +79,7 @@ showMixedAmountWithoutPrice, showMixedAmountWithPrecision, -- * misc. + ltraceamount, tests_Hledger_Data_Amount ) where @@ -125,6 +128,24 @@ amountWithCommodity :: Commodity -> Amount -> Amount amountWithCommodity c (Amount _ q _) = Amount c q Nothing +-- | A more complete amount adding operation. +sumAmounts :: [Amount] -> MixedAmount +sumAmounts = normaliseMixedAmountPreservingPrices . Mixed + +tests_sumAmounts = [ + "sumAmounts" ~: do + -- when adding, we don't convert to the price commodity - just + -- combine what amounts we can. + -- amounts with same unit price + (sumAmounts [(Amount dollar 1 (Just $ UnitPrice $ Mixed [euros 1])), (Amount dollar 1 (Just $ UnitPrice $ Mixed [euros 1]))]) + `is` (Mixed [Amount dollar 2 (Just $ UnitPrice $ Mixed [euros 1])]) + -- amounts with different unit prices + -- amounts with total prices + (sumAmounts [(Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])), (Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]))]) + `is` (Mixed [(Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])), (Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]))]) + -- amounts with no, unit, and/or total prices + ] + -- | Convert an amount to the commodity of its assigned price, if any. Notes: -- -- - price amounts must be MixedAmounts with exactly one component Amount (or there will be a runtime error) @@ -146,16 +167,18 @@ isNegativeAmount :: Amount -> Bool isNegativeAmount Amount{quantity=q} = q < 0 +digits = "123456789" :: String + -- | Does this amount appear to be zero when displayed with its given precision ? isZeroAmount :: Amount -> Bool isZeroAmount a -- a==missingamt = False - | otherwise = (null . filter (`elem` "123456789") . showAmountWithoutPriceOrCommodity) a + | otherwise = (null . filter (`elem` digits) . showAmountWithoutPriceOrCommodity) a -- | Is this amount "really" zero, regardless of the display precision ? -- Since we are using floating point, for now just test to some high precision. isReallyZeroAmount :: Amount -> Bool isReallyZeroAmount a -- a==missingamt = False - | otherwise = (null . filter (`elem` "123456789") . printf ("%."++show zeroprecision++"f") . quantity) a + | otherwise = (null . filter (`elem` digits) . printf ("%."++show zeroprecision++"f") . quantity) a where zeroprecision = 8 -- | Get the string representation of an amount, based on its commodity's @@ -200,10 +223,10 @@ R -> printf "%s%s%s%s" quantity' space sym' price where quantity = showamountquantity a - displayingzero = null $ filter (`elem` "123456789") $ quantity + displayingzero = null $ filter (`elem` digits) $ quantity (quantity',sym') | displayingzero = ("0","") | otherwise = (quantity,quoteCommoditySymbolIfNeeded sym) - space = if (not (null sym') && spaced) then " " else "" + space = if (not (null sym') && spaced) then " " else "" :: String price = maybe "" showPrice pri -- | Get the string representation of the number part of of an amount, @@ -282,9 +305,9 @@ missingmixedamt :: MixedAmount missingmixedamt = Mixed [missingamt] --- | Simplify a mixed amount's component amounts: combine amounts with the --- same commodity and price. Also remove any zero or missing amounts and --- replace an empty amount list with a single zero amount. +-- | Simplify a mixed amount's component amounts: we can combine amounts +-- with the same commodity and unit price. Also remove any zero or missing +-- amounts and replace an empty amount list with a single zero amount. normaliseMixedAmountPreservingPrices :: MixedAmount -> MixedAmount normaliseMixedAmountPreservingPrices (Mixed as) = Mixed as'' where @@ -292,13 +315,29 @@ (_,nonzeros) = partition isReallyZeroAmount $ filter (/= missingamt) as' as' = map sumAmountsUsingFirstPrice $ group $ sort as sort = sortBy (\a1 a2 -> compare (sym a1,price a1) (sym a2,price a2)) - group = groupBy (\a1 a2 -> sym a1 == sym a2 && price a1 == price a2) sym = symbol . commodity + group = groupBy (\a1 a2 -> sym a1 == sym a2 && sameunitprice a1 a2) + where + sameunitprice a1 a2 = + case (price a1, price a2) of + (Nothing, Nothing) -> True + (Just (UnitPrice p1), Just (UnitPrice p2)) -> p1 == p2 + _ -> False tests_normaliseMixedAmountPreservingPrices = [ "normaliseMixedAmountPreservingPrices" ~: do - -- assertEqual "" (Mixed [dollars 2]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, dollars 2]) - assertEqual "" (Mixed [nullamt]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, missingamt]) + assertEqual "discard missing amount" (Mixed [nullamt]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, missingamt]) + assertEqual "combine unpriced same-commodity amounts" (Mixed [dollars 2]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, dollars 2]) + assertEqual "don't combine total-priced amounts" + (Mixed + [Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]) + ,Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1]) + ]) + (normaliseMixedAmountPreservingPrices $ Mixed + [Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]) + ,Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1]) + ]) + ] -- | Simplify a mixed amount's component amounts: combine amounts with @@ -377,6 +416,10 @@ showMixedAmount :: MixedAmount -> String showMixedAmount m = vConcatRightAligned $ map showAmount $ amounts $ normaliseMixedAmountPreservingFirstPrice m +-- | Compact labelled trace of a mixed amount. +ltraceamount :: String -> MixedAmount -> MixedAmount +ltraceamount s = tracewith (((s ++ ": ") ++).showMixedAmount) + -- | Set the display precision in the amount's commodities. setMixedAmountPrecision :: Int -> MixedAmount -> MixedAmount setMixedAmountPrecision p (Mixed as) = Mixed $ map (setAmountPrecision p) as @@ -414,6 +457,7 @@ tests_Hledger_Data_Amount = TestList $ tests_normaliseMixedAmountPreservingPrices + ++ tests_sumAmounts ++ [ -- Amount @@ -434,7 +478,7 @@ let b = (dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]} negate b `is` b{quantity=(-1)} - ,"adding amounts" ~: do + ,"adding amounts without prices" ~: do let a1 = dollars 1.23 let a2 = dollars (-1.23) let a3 = dollars (-1.23) @@ -471,6 +515,15 @@ Amount dollar0 (-1) Nothing, Amount dollar (-0.25) Nothing]) `is` Mixed [Amount unknown 0 Nothing] + + ,"adding mixed amounts with total prices" ~: do + (sum $ map (Mixed . (\a -> [a])) + [Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]) + ,Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1]) + ]) + `is` (Mixed [Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1]) + ,Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1]) + ]) ,"showMixedAmount" ~: do showMixedAmount (Mixed [dollars 1]) `is` "$1.00" diff --git a/Hledger/Data/Commodity.hs b/Hledger/Data/Commodity.hs --- a/Hledger/Data/Commodity.hs +++ b/Hledger/Data/Commodity.hs @@ -18,7 +18,8 @@ import Hledger.Utils -nonsimplecommoditychars = "0123456789-.@;\n \"" +-- characters than can't be in a non-quoted commodity symbol +nonsimplecommoditychars = "0123456789-.@;\n \"{}" :: String quoteCommoditySymbolIfNeeded s | any (`elem` nonsimplecommoditychars) s = "\"" ++ s ++ "\"" | otherwise = s diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoMonoLocalBinds #-} {-| Date parsing and utilities for hledger. diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -340,7 +340,7 @@ | otherwise = "real postings are off by " ++ showMixedAmount (costOfMixedAmount rsum) bvmsg | isReallyZeroMixedAmountCost bvsum = "" | otherwise = "balanced virtual postings are off by " ++ showMixedAmount (costOfMixedAmount bvsum) - sep = if not (null rmsg) && not (null bvmsg) then "; " else "" + sep = if not (null rmsg) && not (null bvmsg) then "; " else "" :: String transactionActualDate :: Transaction -> Day transactionActualDate = tdate @@ -455,12 +455,14 @@ [Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing, Posting False "b" (Mixed [dollars 1]) "" RegularPosting [] Nothing ] "")) + assertBool "detect unbalanced entry, multiple missing amounts" (isLeft $ balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" [] [Posting False "a" missingmixedamt "" RegularPosting [] Nothing, Posting False "b" missingmixedamt "" RegularPosting [] Nothing ] "")) + let e = balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "" "" [] [Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing, Posting False "b" missingmixedamt "" RegularPosting [] Nothing @@ -471,6 +473,7 @@ (case e of Right e' -> (pamount $ last $ tpostings e') Left _ -> error' "should not happen") + let e = balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" [] [Posting False "a" (Mixed [dollars 1.35]) "" RegularPosting [] Nothing, Posting False "b" (Mixed [euros (-1)]) "" RegularPosting [] Nothing @@ -485,6 +488,18 @@ (case e of Right e' -> (pamount $ head $ tpostings e') Left _ -> error' "should not happen") + + assertBool "balanceTransaction balances based on cost if there are unit prices" (isRight $ + balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" [] + [Posting False "a" (Mixed [Amount dollar 1 (Just $ UnitPrice $ Mixed [euros 2])]) "" RegularPosting [] Nothing + ,Posting False "a" (Mixed [Amount dollar (-2) (Just $ UnitPrice $ Mixed [euros 1])]) "" RegularPosting [] Nothing + ] "")) + + assertBool "balanceTransaction balances based on cost if there are total prices" (isRight $ + balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" [] + [Posting False "a" (Mixed [Amount dollar 1 (Just $ TotalPrice $ Mixed [euros 1])]) "" RegularPosting [] Nothing + ,Posting False "a" (Mixed [Amount dollar (-2) (Just $ TotalPrice $ Mixed [euros 1])]) "" RegularPosting [] Nothing + ] "")) ,"isTransactionBalanced" ~: do let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -239,6 +239,7 @@ aname :: AccountName, -- ^ this account's full name aebalance :: MixedAmount, -- ^ this account's balance, excluding subaccounts asubs :: [Account], -- ^ sub-accounts + -- anumpostings :: Int -- ^ number of postings to this account -- derived from the above: aibalance :: MixedAmount, -- ^ this account's balance, including subaccounts aparent :: Maybe Account, -- ^ parent account diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs --- a/Hledger/Read/JournalReader.hs +++ b/Hledger/Read/JournalReader.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, NoMonoLocalBinds #-} {-| A reader for hledger's journal file format @@ -488,6 +488,8 @@ account <- modifiedaccountname let (ptype, account') = (accountNamePostingType account, unbracket account) amount <- spaceandamountormissing + _ <- balanceassertion + _ <- fixedlotprice many spacenonewline (inlinecomment, inlinetag) <- inlinecomment (nextlinecomments, nextlinetags) <- commentlines @@ -516,6 +518,9 @@ assertBool "posting parses a quoted commodity with numbers" (isRight $ parseWithCtx nullctx posting " a 1 \"DE123\"\n") + + ,"posting parses balance assertions and fixed lot prices" ~: do + assertBool "" (isRight $ parseWithCtx nullctx posting " a 1 \"DE123\" =$1 { =2.2 EUR} \n") ] -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect. @@ -564,8 +569,8 @@ assertParseEqual (parseWithCtx nullctx spaceandamountormissing "") missingmixedamt ] --- | Parse an amount, with an optional left or right currency symbol and --- optional price. +-- | Parse an amount, optionally with a left or right currency symbol, +-- price, and/or (ignored) ledger-style balance assertion. amount :: GenParser Char JournalContext MixedAmount amount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount @@ -654,6 +659,31 @@ many spacenonewline a <- amount -- XXX can parse more prices ad infinitum, shouldn't return $ Just $ UnitPrice a)) + <|> return Nothing + +balanceassertion :: GenParser Char JournalContext (Maybe MixedAmount) +balanceassertion = + try (do + many spacenonewline + char '=' + many spacenonewline + a <- amount -- XXX should restrict to a simple amount + return $ Just a) + <|> return Nothing + +-- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices +fixedlotprice :: GenParser Char JournalContext (Maybe MixedAmount) +fixedlotprice = + try (do + many spacenonewline + char '{' + many spacenonewline + char '=' + many spacenonewline + a <- amount -- XXX should restrict to a simple amount + many spacenonewline + char '}' + return $ Just a) <|> return Nothing -- | Parse a numeric quantity for its value and display attributes. Some diff --git a/Hledger/Utils.hs b/Hledger/Utils.hs --- a/Hledger/Utils.hs +++ b/Hledger/Utils.hs @@ -55,7 +55,7 @@ uppercase = map toUpper strip = lstrip . rstrip -lstrip = dropWhile (`elem` " \t") +lstrip = dropWhile (`elem` " \t") :: String -> String rstrip = reverse . lstrip . reverse elideLeft width s = @@ -314,6 +314,12 @@ -- debugging + +-- more: +-- http://hackage.haskell.org/packages/archive/TraceUtils/0.1.0.2/doc/html/Debug-TraceUtils.html +-- http://hackage.haskell.org/packages/archive/trace-call/0.1/doc/html/Debug-TraceCall.html +-- http://hackage.haskell.org/packages/archive/htrace/0.1/doc/html/Debug-HTrace.html +-- http://hackage.haskell.org/packages/archive/traced/2009.7.20/doc/html/Debug-Traced.html -- | trace (print on stdout at runtime) a showable expression -- (for easily tracing in the middle of a complex expression) diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -1,5 +1,5 @@ name: hledger-lib -version: 0.19 +version: 0.19.1 category: Finance synopsis: Core data types, parsers and utilities for the hledger accounting tool. description: