diff --git a/Hledger.hs b/Hledger.hs new file mode 100644 --- /dev/null +++ b/Hledger.hs @@ -0,0 +1,11 @@ +module Hledger ( + module Hledger.Data + ,module Hledger.Read + ,module Hledger.Reports + ,module Hledger.Utils +) +where +import Hledger.Data +import Hledger.Read +import Hledger.Reports +import Hledger.Utils diff --git a/Hledger/Data.hs b/Hledger/Data.hs --- a/Hledger/Data.hs +++ b/Hledger/Data.hs @@ -13,28 +13,30 @@ module Hledger.Data.Amount, module Hledger.Data.Commodity, module Hledger.Data.Dates, - module Hledger.Data.Transaction, - module Hledger.Data.Ledger, module Hledger.Data.Journal, + module Hledger.Data.Ledger, + module Hledger.Data.Matching, module Hledger.Data.Posting, module Hledger.Data.TimeLog, + module Hledger.Data.Transaction, module Hledger.Data.Types, - module Hledger.Data.Utils, tests_Hledger_Data ) where +import Test.HUnit + import Hledger.Data.Account import Hledger.Data.AccountName import Hledger.Data.Amount import Hledger.Data.Commodity import Hledger.Data.Dates -import Hledger.Data.Transaction -import Hledger.Data.Ledger import Hledger.Data.Journal +import Hledger.Data.Ledger +import Hledger.Data.Matching import Hledger.Data.Posting import Hledger.Data.TimeLog +import Hledger.Data.Transaction import Hledger.Data.Types -import Hledger.Data.Utils tests_Hledger_Data = TestList [ @@ -45,9 +47,9 @@ ,tests_Hledger_Data_Dates ,tests_Hledger_Data_Journal ,tests_Hledger_Data_Ledger + ,tests_Hledger_Data_Matching ,tests_Hledger_Data_Posting ,tests_Hledger_Data_TimeLog ,tests_Hledger_Data_Transaction -- ,tests_Hledger_Data_Types - -- ,tests_Hledger_Data_Utils ] diff --git a/Hledger/Data/Account.hs b/Hledger/Data/Account.hs --- a/Hledger/Data/Account.hs +++ b/Hledger/Data/Account.hs @@ -12,9 +12,11 @@ module Hledger.Data.Account where -import Hledger.Data.Utils -import Hledger.Data.Types +import Test.HUnit +import Text.Printf + import Hledger.Data.Amount +import Hledger.Data.Types instance Show Account where diff --git a/Hledger/Data/AccountName.hs b/Hledger/Data/AccountName.hs --- a/Hledger/Data/AccountName.hs +++ b/Hledger/Data/AccountName.hs @@ -9,13 +9,18 @@ module Hledger.Data.AccountName where -import Hledger.Data.Utils -import Hledger.Data.Types +import Data.List import Data.Map (Map) +import Data.Tree +import Test.HUnit +import Text.Printf import qualified Data.Map as M +import Hledger.Data.Types +import Hledger.Utils + -- change to use a different separator for nested accounts acctsepchar = ':' @@ -172,6 +177,24 @@ clipAccountName :: Int -> AccountName -> AccountName clipAccountName n = accountNameFromComponents . take n . accountNameComponents + +-- | Convert an account name to a regular expression matching it and its subaccounts. +accountNameToAccountRegex :: String -> String +accountNameToAccountRegex "" = "" +accountNameToAccountRegex a = printf "^%s(:|$)" a + +-- | Convert an account name to a regular expression matching it and its subaccounts. +accountNameToAccountOnlyRegex :: String -> String +accountNameToAccountOnlyRegex "" = "" +accountNameToAccountOnlyRegex a = printf "^%s$" a + +-- | Convert an exact account-matching regular expression to a plain account name. +accountRegexToAccountName :: String -> String +accountRegexToAccountName = regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1" + +-- | Does this string look like an exact account-matching regular expression ? +isAccountRegex :: String -> Bool +isAccountRegex s = take 1 s == "^" && (take 5 $ reverse s) == ")$|:(" tests_Hledger_Data_AccountName = TestList [ diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -1,8 +1,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-| -An 'Amount' is some quantity of money, shares, or anything else. - -A simple amount is a 'Commodity', quantity pair: +A simple 'Amount' is some quantity of money, shares, or anything else. +It has a (possibly null) 'Commodity' and a numeric quantity: @ $1 @@ -14,116 +13,121 @@ 0 @ -An amount may also have a per-unit price, or conversion rate, in terms -of some other commodity. If present, this is displayed after \@: +It may also have an assigned 'Price', representing this amount's per-unit +or total cost in a different commodity. If present, this is rendered like +so: @ - EUR 3 \@ $1.35 + EUR 2 \@ $1.50 (unit price) + EUR 2 \@\@ $3 (total price) @ -A 'MixedAmount' is zero or more simple amounts. Mixed amounts are -usually normalised so that there is no more than one amount in each -commodity, and no zero amounts (or, there is just a single zero amount -and no others.): +A 'MixedAmount' is zero or more simple amounts, so can represent multiple +commodities; this is the type most often used: @ + 0 $50 + EUR 3 16h + $13.55 + AAPL 500 + 6 oranges - 0 @ -We can do limited arithmetic with simple or mixed amounts: either -price-preserving arithmetic with similarly-priced amounts, or -price-discarding arithmetic which ignores and discards prices. +When a mixed amount has been \"normalised\", it has no more than one amount +in each commodity and no zero amounts; or it has just a single zero amount +and no others. --} +Limited arithmetic with simple and mixed amounts is supported, best used +with similar amounts since it mostly ignores assigned prices and commodity +exchange rates. --- XXX due for review/rewrite +-} module Hledger.Data.Amount ( - amounts, - canonicaliseAmount, - canonicaliseMixedAmount, - convertMixedAmountToSimilarCommodity, - costOfAmount, - costOfMixedAmount, - divideAmount, - divideMixedAmount, - isNegativeMixedAmount, - isReallyZeroMixedAmountCost, - isZeroMixedAmount, - maxprecision, - maxprecisionwithpoint, - missingamt, - normaliseMixedAmount, - nullamt, - nullmixedamt, - punctuatethousands, - setAmountPrecision, - setMixedAmountPrecision, - showAmountDebug, - showMixedAmount, - showMixedAmountDebug, - showMixedAmountOrZero, - showMixedAmountOrZeroWithoutPrice, - showMixedAmountWithoutPrice, - showMixedAmountWithPrecision, - sumMixedAmountsPreservingHighestPrecision, - tests_Hledger_Data_Amount - -- Hledger.Data.Amount.tests_Hledger_Data_Amount - ) -where -import qualified Data.Map as Map + -- * Amount + nullamt, + amountWithCommodity, + canonicaliseAmountCommodity, + setAmountPrecision, + -- ** arithmetic + costOfAmount, + divideAmount, + -- ** rendering + showAmount, + showAmountDebug, + showAmountWithoutPrice, + maxprecision, + maxprecisionwithpoint, + -- * MixedAmount + nullmixedamt, + missingamt, + amounts, + normaliseMixedAmount, + canonicaliseMixedAmountCommodity, + mixedAmountWithCommodity, + setMixedAmountPrecision, + -- ** arithmetic + costOfMixedAmount, + divideMixedAmount, + isNegativeMixedAmount, + isZeroMixedAmount, + isReallyZeroMixedAmountCost, + -- ** rendering + showMixedAmount, + showMixedAmountDebug, + showMixedAmountWithoutPrice, + showMixedAmountWithPrecision, + -- * misc. + tests_Hledger_Data_Amount +) where + +import Data.Char (isDigit) +import Data.List import Data.Map (findWithDefault) +import Test.HUnit +import Text.Printf +import qualified Data.Map as Map -import Hledger.Data.Utils import Hledger.Data.Types import Hledger.Data.Commodity +import Hledger.Utils -instance Show Amount where show = showAmount -instance Show MixedAmount where show = showMixedAmount deriving instance Show HistoricalPrice +------------------------------------------------------------------------------- +-- Amount + +instance Show Amount where show = showAmount + instance Num Amount where abs (Amount c q p) = Amount c (abs q) p signum (Amount c q p) = Amount c (signum q) p fromInteger i = Amount (comm "") (fromInteger i) Nothing + negate a@Amount{quantity=q} = a{quantity=(-q)} (+) = similarAmountsOp (+) (-) = similarAmountsOp (-) (*) = similarAmountsOp (*) -instance Num MixedAmount where - fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing] - negate (Mixed as) = Mixed $ map negateAmountPreservingPrice as - where negateAmountPreservingPrice a = (-a){price=price a} - (+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs - (*) = error' "programming error, mixed amounts do not support multiplication" - abs = error' "programming error, mixed amounts do not support abs" - signum = error' "programming error, mixed amounts do not support signum" +-- | The empty simple amount. +nullamt :: Amount +nullamt = Amount unknown 0 Nothing --- | Apply a binary arithmetic operator to two amounts, after converting --- the first to the commodity (and display precision) of the second in a --- simplistic way. This should be used only for two amounts in the same --- commodity, since the conversion rate is assumed to be 1. --- NB preserving the second commodity is preferred since sum and other --- folds start with the no-commodity zero amount. +-- | Apply a binary arithmetic operator to two amounts, ignoring and +-- discarding any assigned prices, and converting the first to the +-- commodity of the second in a simplistic way (1-1 exchange rate). +-- The highest precision of either amount is preserved in the result. similarAmountsOp :: (Double -> Double -> Double) -> Amount -> Amount -> Amount -similarAmountsOp op a (Amount bc bq _) = - Amount bc (quantity (convertAmountToSimilarCommodity bc a) `op` bq) Nothing - --- | Convert an amount to the specified commodity, assuming an exchange rate of 1. -convertAmountToSimilarCommodity :: Commodity -> Amount -> Amount -convertAmountToSimilarCommodity c (Amount _ q _) = Amount c q Nothing +similarAmountsOp op a@(Amount Commodity{precision=ap} _ _) (Amount bc@Commodity{precision=bp} bq _) = + Amount bc{precision=max ap bp} (quantity (amountWithCommodity bc a) `op` bq) Nothing --- | Convert a mixed amount to the specified commodity, assuming an exchange rate of 1. -convertMixedAmountToSimilarCommodity :: Commodity -> MixedAmount -> Amount -convertMixedAmountToSimilarCommodity c (Mixed as) = Amount c total Nothing - where - total = sum $ map (quantity . convertAmountToSimilarCommodity c) as +-- | Convert an amount to the specified commodity, ignoring and discarding +-- any assigned prices and assuming an exchange rate of 1. +amountWithCommodity :: Commodity -> Amount -> Amount +amountWithCommodity c (Amount _ q _) = Amount c q Nothing --- | Convert an amount to the commodity of its saved price, if any. Notes: +-- | 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) +-- -- - price amounts should be positive, though this is not currently enforced costOfAmount :: Amount -> Amount costOfAmount a@(Amount _ q price) = @@ -133,14 +137,33 @@ Just (TotalPrice (Mixed [Amount pc pq Nothing])) -> Amount pc (pq*signum q) Nothing _ -> error' "costOfAmount: Malformed price encountered, programmer error" +-- | Divide an amount's quantity by a constant. +divideAmount :: Amount -> Double -> Amount +divideAmount a@Amount{quantity=q} d = a{quantity=q/d} + +-- | Is this amount negative ? The price is ignored. +isNegativeAmount :: Amount -> Bool +isNegativeAmount Amount{quantity=q} = q < 0 + +-- | Does this amount appear to be zero when displayed with its given precision ? +isZeroAmount :: Amount -> Bool +isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPriceOrCommodity + +-- | 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 = null . filter (`elem` "123456789") . printf ("%."++show zeroprecision++"f") . quantity + where zeroprecision = 8 + -- | Get the string representation of an amount, based on its commodity's -- display settings except using the specified precision. showAmountWithPrecision :: Int -> Amount -> String showAmountWithPrecision p = showAmount . setAmountPrecision p +-- | Set the display precision in the amount's commodity. +setAmountPrecision :: Int -> Amount -> Amount setAmountPrecision p a@Amount{commodity=c} = a{commodity=c{precision=p}} --- XXX refactor -- | Get the unambiguous string representation of an amount, for debugging. showAmountDebug :: Amount -> String showAmountDebug (Amount c q pri) = printf "Amount {commodity = %s, quantity = %s, price = %s}" @@ -163,7 +186,8 @@ showPriceDebug (TotalPrice pa) = " @@ " ++ showMixedAmountDebug pa -- | Get the string representation of an amount, based on its commodity's --- display settings. Amounts which look like zero are rendered without sign or commodity. +-- display settings. String representations equivalent to zero are +-- converted to just \"0\". showAmount :: Amount -> String showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = "" -- can appear in an error message showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) _ pri) = @@ -190,15 +214,6 @@ | p == maxprecision = chopdotzero $ printf "%f" q | otherwise = printf ("%."++show p++"f") q -chopdotzero str = reverse $ case reverse str of - '0':'.':s -> s - s -> s - --- | A special precision value meaning show all available digits. -maxprecision = 999998 --- | Similar, forces display of a decimal point. -maxprecisionwithpoint = 999999 - -- | Replace a number string's decimal point with the specified character, -- and add the specified digit group separators. punctuatenumber :: Char -> Char -> [Int] -> String -> String @@ -217,35 +232,89 @@ | otherwise = let (s,rest) = splitAt g str in s ++ [sep] ++ addseps sep gs rest --- | Add thousands-separating commas to a decimal number string -punctuatethousands :: String -> String -punctuatethousands s = - sign ++ addcommas int ++ frac - where - (sign,num) = break isDigit s - (int,frac) = break (=='.') num - addcommas = reverse . concat . intersperse "," . triples . reverse - triples [] = [] - triples l = take 3 l : triples (drop 3 l) +chopdotzero str = reverse $ case reverse str of + '0':'.':s -> s + s -> s --- | Does this amount appear to be zero when displayed with its given precision ? -isZeroAmount :: Amount -> Bool -isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPriceOrCommodity +-- | For rendering: a special precision value which means show all available digits. +maxprecision :: Int +maxprecision = 999998 --- | 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 = null . filter (`elem` "123456789") . printf ("%."++show zeroprecision++"f") . quantity - where zeroprecision = 8 +-- | For rendering: a special precision value which forces display of a decimal point. +maxprecisionwithpoint :: Int +maxprecisionwithpoint = 999999 --- | Is this amount negative ? The price is ignored. -isNegativeAmount :: Amount -> Bool -isNegativeAmount Amount{quantity=q} = q < 0 +-- | Replace an amount's commodity with the canonicalised version from +-- the provided commodity map. +canonicaliseAmountCommodity :: Maybe (Map.Map String Commodity) -> Amount -> Amount +canonicaliseAmountCommodity Nothing = id +canonicaliseAmountCommodity (Just canonicalcommoditymap) = fixamount + where + -- like journalCanonicaliseAmounts + fixamount a@Amount{commodity=c} = a{commodity=fixcommodity c} + fixcommodity c@Commodity{symbol=s} = findWithDefault c s canonicalcommoditymap --- | Access a mixed amount's components. +------------------------------------------------------------------------------- +-- MixedAmount + +instance Show MixedAmount where show = showMixedAmount + +instance Num MixedAmount where + fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing] + negate (Mixed as) = Mixed $ map negate as + (+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs + (*) = error' "programming error, mixed amounts do not support multiplication" + abs = error' "programming error, mixed amounts do not support abs" + signum = error' "programming error, mixed amounts do not support signum" + +-- | The empty mixed amount. +nullmixedamt :: MixedAmount +nullmixedamt = Mixed [] + +-- | A temporary value for parsed transactions which had no amount specified. +missingamt :: MixedAmount +missingamt = Mixed [Amount unknown{symbol="AUTO"} 0 Nothing] + +-- | Simplify a mixed amount by removing redundancy in its component amounts, +-- as follows: +-- +-- 1. combine amounts which have the same commodity, discarding all but the first's price. +-- +-- 2. remove zero amounts +-- +-- 3. if there are no amounts at all, add a single zero amount +normaliseMixedAmount :: MixedAmount -> MixedAmount +normaliseMixedAmount (Mixed as) = Mixed as'' + where + as'' = if null nonzeros then [nullamt] else nonzeros + (_,nonzeros) = partition (\a -> isReallyZeroAmount a && Mixed [a] /= missingamt) as' + as' = map sumAmountsDiscardingAllButFirstPrice $ group $ sort as + sort = sortBy (\a1 a2 -> compare (sym a1) (sym a2)) + group = groupBy (\a1 a2 -> sym a1 == sym a2) + sym = symbol . commodity + +sumAmountsDiscardingAllButFirstPrice [] = nullamt +sumAmountsDiscardingAllButFirstPrice as = (sum as){price=price $ head as} + +-- | Get a mixed amount's component amounts. amounts :: MixedAmount -> [Amount] amounts (Mixed as) = as +-- | Convert a mixed amount's component amounts to the commodity of their +-- assigned price, if any. +costOfMixedAmount :: MixedAmount -> MixedAmount +costOfMixedAmount (Mixed as) = Mixed $ map costOfAmount as + +-- | Divide a mixed amount's quantities by a constant. +divideMixedAmount :: MixedAmount -> Double -> MixedAmount +divideMixedAmount (Mixed as) d = Mixed $ map (flip divideAmount d) as + +-- | Is this mixed amount negative, if it can be normalised to a single commodity ? +isNegativeMixedAmount :: MixedAmount -> Maybe Bool +isNegativeMixedAmount m = case as of [a] -> Just $ isNegativeAmount a + _ -> Nothing + where as = amounts $ normaliseMixedAmount m + -- | Does this mixed amount appear to be zero when displayed with its given precision ? isZeroMixedAmount :: MixedAmount -> Bool isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmount @@ -254,22 +323,20 @@ isReallyZeroMixedAmount :: MixedAmount -> Bool isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmount --- | Is this mixed amount negative, if it can be normalised to a single commodity ? -isNegativeMixedAmount :: MixedAmount -> Maybe Bool -isNegativeMixedAmount m = case as of [a] -> Just $ isNegativeAmount a - _ -> Nothing - where - as = amounts $ normaliseMixedAmount m - -- | Is this mixed amount "really" zero, after converting to cost -- commodities where possible ? isReallyZeroMixedAmountCost :: MixedAmount -> Bool isReallyZeroMixedAmountCost = isReallyZeroMixedAmount . costOfMixedAmount --- -- | MixedAmount derives Eq in Types.hs, but that doesn't know that we --- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code in there. --- -- When zero equality is important, use this, for now; should be used --- -- everywhere. +-- -- | Convert a mixed amount to the specified commodity, assuming an exchange rate of 1. +mixedAmountWithCommodity :: Commodity -> MixedAmount -> Amount +mixedAmountWithCommodity c (Mixed as) = Amount c total Nothing + where + total = sum $ map (quantity . amountWithCommodity c) as + +-- -- | MixedAmount derived Eq instance in Types.hs doesn't know that we +-- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code over there. +-- -- For now, use this when cross-commodity zero equality is important. -- mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool -- mixedAmountEquals a b = amounts a' == amounts b' || (isZeroMixedAmount a' && isZeroMixedAmount b') -- where a' = normaliseMixedAmount a @@ -281,13 +348,13 @@ showMixedAmount :: MixedAmount -> String showMixedAmount m = vConcatRightAligned $ map show $ amounts $ normaliseMixedAmount m +-- | Set the display precision in the amount's commodities. setMixedAmountPrecision :: Int -> MixedAmount -> MixedAmount setMixedAmountPrecision p (Mixed as) = Mixed $ map (setAmountPrecision p) as -- | Get the string representation of a mixed amount, showing each of its -- component amounts with the specified precision, ignoring their --- commoditys' display precision settings. NB a mixed amount can have an --- empty amounts list in which case it shows as \"\". +-- commoditys' display precision settings. showMixedAmountWithPrecision :: Int -> MixedAmount -> String showMixedAmountWithPrecision p m = vConcatRightAligned $ map (showAmountWithPrecision p) $ amounts $ normaliseMixedAmount m @@ -302,169 +369,70 @@ showMixedAmountWithoutPrice :: MixedAmount -> String showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth as where - (Mixed as) = normaliseMixedAmountIgnoringPrice m + (Mixed as) = normaliseMixedAmount $ stripPrices m + stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{price=Nothing} width = maximum $ map (length . show) as showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice --- | Get the string representation of a mixed amount, and if it --- appears to be all zero just show a bare 0, ledger-style. -showMixedAmountOrZero :: MixedAmount -> String -showMixedAmountOrZero a | a == missingamt = "" - | isZeroMixedAmount a = "0" - | otherwise = showMixedAmount a - --- | Get the string representation of a mixed amount, or a bare 0, --- without any \@ prices. -showMixedAmountOrZeroWithoutPrice :: MixedAmount -> String -showMixedAmountOrZeroWithoutPrice a - | isZeroMixedAmount a = "0" - | otherwise = showMixedAmountWithoutPrice a - --- | Simplify a mixed amount by removing redundancy in its component amounts, as follows: --- 1. sum amounts which have the same commodity (ignoring their price) --- 2. remove zero amounts --- 3. if there are no amounts at all, add a single zero amount -normaliseMixedAmount :: MixedAmount -> MixedAmount -normaliseMixedAmount (Mixed as) = Mixed as'' - where - as'' = if null nonzeros then [nullamt] else nonzeros - (_,nonzeros) = partition (\a -> isReallyZeroAmount a && Mixed [a] /= missingamt) as' - as' = map sumSamePricedAmountsPreservingPrice $ group $ sort as - sort = sortBy (\a1 a2 -> compare (sym a1) (sym a2)) - group = groupBy (\a1 a2 -> sym a1 == sym a2) - sym = symbol . commodity - --- | Set a mixed amount's commodity to the canonicalised commodity from --- the provided commodity map. -canonicaliseMixedAmount :: Maybe (Map.Map String Commodity) -> MixedAmount -> MixedAmount -canonicaliseMixedAmount canonicalcommoditymap (Mixed as) = Mixed $ map (canonicaliseAmount canonicalcommoditymap) as - --- | Set an amount's commodity to the canonicalised commodity from +-- | Replace a mixed amount's commodity with the canonicalised version from -- the provided commodity map. -canonicaliseAmount :: Maybe (Map.Map String Commodity) -> Amount -> Amount -canonicaliseAmount Nothing = id -canonicaliseAmount (Just canonicalcommoditymap) = fixamount - where - -- like journalCanonicaliseAmounts - fixamount a@Amount{commodity=c} = a{commodity=fixcommodity c} - fixcommodity c@Commodity{symbol=s} = findWithDefault c s canonicalcommoditymap - --- various sum variants.. - -sumAmountsDiscardingPrice [] = nullamt -sumAmountsDiscardingPrice as = (sum as){price=Nothing} - -sumSamePricedAmountsPreservingPrice [] = nullamt -sumSamePricedAmountsPreservingPrice as = (sum as){price=price $ head as} - --- | Simplify a mixed amount by combining any component amounts which have --- the same commodity, ignoring and discarding their unit prices if any. --- Also removes zero amounts, or adds a single zero amount if there are no --- amounts at all. -normaliseMixedAmountIgnoringPrice :: MixedAmount -> MixedAmount -normaliseMixedAmountIgnoringPrice (Mixed as) = Mixed as'' - where - as'' = map sumAmountsDiscardingPrice $ group $ sort as' - group = groupBy samesymbol where samesymbol a1 a2 = sym a1 == sym a2 - sort = sortBy (comparing sym) - sym = symbol . commodity - as' | null nonzeros = [head $ zeros ++ [nullamt]] - | otherwise = nonzeros - where (zeros,nonzeros) = partition isZeroAmount as - -sumMixedAmountsPreservingHighestPrecision :: [MixedAmount] -> MixedAmount -sumMixedAmountsPreservingHighestPrecision ms = foldl' (+~) 0 ms - where (+~) (Mixed as) (Mixed bs) = normaliseMixedAmountPreservingHighestPrecision $ Mixed $ as ++ bs - -normaliseMixedAmountPreservingHighestPrecision :: MixedAmount -> MixedAmount -normaliseMixedAmountPreservingHighestPrecision (Mixed as) = Mixed as'' - where - as'' = map sumSamePricedAmountsPreservingPriceAndHighestPrecision $ group $ sort as' - sort = sortBy cmpsymbolandprice - cmpsymbolandprice a1 a2 = compare (sym a1,price a1) (sym a2,price a2) - group = groupBy samesymbolandprice - samesymbolandprice a1 a2 = (sym a1 == sym a2) && (price a1 == price a2) - sym = symbol . commodity - as' | null nonzeros = [head $ zeros ++ [nullamt]] - | otherwise = nonzeros - (zeros,nonzeros) = partition isReallyZeroAmount as - -sumSamePricedAmountsPreservingPriceAndHighestPrecision [] = nullamt -sumSamePricedAmountsPreservingPriceAndHighestPrecision as = (sumAmountsPreservingHighestPrecision as){price=price $ head as} - -sumAmountsPreservingHighestPrecision :: [Amount] -> Amount -sumAmountsPreservingHighestPrecision as = foldl' (+~) 0 as - where (+~) = amountopPreservingHighestPrecision (+) - -amountopPreservingHighestPrecision :: (Double -> Double -> Double) -> Amount -> Amount -> Amount -amountopPreservingHighestPrecision op a@(Amount ac@Commodity{precision=ap} _ _) (Amount bc@Commodity{precision=bp} bq _) = - Amount c q Nothing - where - q = quantity (convertAmountToSimilarCommodity bc a) `op` bq - c = if ap > bp then ac else bc --- - --- | Convert a mixed amount's component amounts to the commodity of their --- saved price, if any. -costOfMixedAmount :: MixedAmount -> MixedAmount -costOfMixedAmount (Mixed as) = Mixed $ map costOfAmount as - --- | Divide a mixed amount's quantities by some constant. -divideMixedAmount :: MixedAmount -> Double -> MixedAmount -divideMixedAmount (Mixed as) d = Mixed $ map (flip divideAmount d) as - --- | Divide an amount's quantity by some constant. -divideAmount :: Amount -> Double -> Amount -divideAmount a@Amount{quantity=q} d = a{quantity=q/d} - --- | The empty simple amount. -nullamt :: Amount -nullamt = Amount unknown 0 Nothing - --- | The empty mixed amount. -nullmixedamt :: MixedAmount -nullmixedamt = Mixed [] - --- | A temporary value for parsed transactions which had no amount specified. -missingamt :: MixedAmount -missingamt = Mixed [Amount unknown{symbol="AUTO"} 0 Nothing] +canonicaliseMixedAmountCommodity :: Maybe (Map.Map String Commodity) -> MixedAmount -> MixedAmount +canonicaliseMixedAmountCommodity canonicalcommoditymap (Mixed as) = Mixed $ map (canonicaliseAmountCommodity canonicalcommoditymap) as +------------------------------------------------------------------------------- +-- misc tests_Hledger_Data_Amount = TestList [ - "showAmount" ~: do - showAmount (dollars 0 + pounds 0) `is` "0" + -- Amount - ,"showMixedAmount" ~: do - showMixedAmount (Mixed [Amount dollar 0 Nothing]) `is` "0" - showMixedAmount (Mixed []) `is` "0" - showMixedAmount missingamt `is` "" + "costOfAmount" ~: do + costOfAmount (euros 1) `is` euros 1 + costOfAmount (euros 2){price=Just $ UnitPrice $ Mixed [dollars 2]} `is` dollars 4 + costOfAmount (euros 1){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars 2 + costOfAmount (euros (-1)){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars (-2) - ,"showMixedAmountOrZero" ~: do - showMixedAmountOrZero (Mixed [Amount dollar 0 Nothing]) `is` "0" - showMixedAmountOrZero (Mixed []) `is` "0" - showMixedAmountOrZero missingamt `is` "" + ,"isZeroAmount" ~: do + assertBool "" $ isZeroAmount $ Amount unknown 0 Nothing + assertBool "" $ isZeroAmount $ dollars 0 - ,"amount arithmetic" ~: do + ,"negating amounts" ~: do + let a = dollars 1 + negate a `is` a{quantity=(-1)} + let b = (dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]} + negate b `is` b{quantity=(-1)} + + ,"adding amounts" ~: do let a1 = dollars 1.23 - let a2 = Amount (comm "$") (-1.23) Nothing - let a3 = Amount (comm "$") (-1.23) Nothing + let a2 = dollars (-1.23) + let a3 = dollars (-1.23) (a1 + a2) `is` Amount (comm "$") 0 Nothing (a1 + a3) `is` Amount (comm "$") 0 Nothing (a2 + a3) `is` Amount (comm "$") (-2.46) Nothing (a3 + a3) `is` Amount (comm "$") (-2.46) Nothing - -- arithmetic with different commodities currently assumes conversion rate 1: - let a4 = euros (-1.23) - assertBool "" $ isZeroAmount (a1 + a4) - - sum [a2,a3] `is` Amount (comm "$") (-2.46) Nothing - sum [a3,a3] `is` Amount (comm "$") (-2.46) Nothing sum [a1,a2,a3,-a3] `is` Amount (comm "$") 0 Nothing - let dollar0 = dollar{precision=0} - (sum [Amount dollar 1.25 Nothing, Amount dollar0 (-1) Nothing, Amount dollar (-0.25) Nothing]) - `is` (Amount dollar 0 Nothing) + -- highest precision is preserved + let ap1 = (dollars 1){commodity=dollar{precision=1}} + ap3 = (dollars 1){commodity=dollar{precision=3}} + (sum [ap1,ap3]) `is` ap3{quantity=2} + (sum [ap3,ap1]) `is` ap3{quantity=2} + -- adding different commodities assumes conversion rate 1 + assertBool "" $ isZeroAmount (a1 - euros 1.23) - ,"mixed amount arithmetic" ~: do + ,"showAmount" ~: do + showAmount (dollars 0 + pounds 0) `is` "0" + + -- MixedAmount + + ,"normaliseMixedAmount" ~: do + normaliseMixedAmount (Mixed []) `is` Mixed [nullamt] + assertBool "" $ isZeroMixedAmount $ normaliseMixedAmount (Mixed [Amount {commodity=dollar, quantity=10, price=Nothing} + ,Amount {commodity=dollar, quantity=10, price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))} + ,Amount {commodity=dollar, quantity=(-10), price=Nothing} + ,Amount {commodity=dollar, quantity=(-10), price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))} + ]) + + ,"adding mixed amounts" ~: do let dollar0 = dollar{precision=0} (sum $ map (Mixed . (\a -> [a])) [Amount dollar 1.25 Nothing, @@ -472,24 +440,16 @@ Amount dollar (-0.25) Nothing]) `is` Mixed [Amount unknown 0 Nothing] - ,"normaliseMixedAmount" ~: do - normaliseMixedAmount (Mixed []) `is` Mixed [nullamt] - assertBool "" $ isZeroMixedAmount $ normaliseMixedAmount (Mixed [Amount {commodity=dollar, quantity=10, price=Nothing} - ,Amount {commodity=dollar, quantity=10, price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))} - ,Amount {commodity=dollar, quantity=(-10), price=Nothing} - ,Amount {commodity=dollar, quantity=(-10), price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))} - ]) - - ,"punctuatethousands 1" ~: punctuatethousands "" `is` "" - - ,"punctuatethousands 2" ~: punctuatethousands "1234567.8901" `is` "1,234,567.8901" - - ,"punctuatethousands 3" ~: punctuatethousands "-100" `is` "-100" + ,"showMixedAmount" ~: do + showMixedAmount (Mixed [dollars 1]) `is` "$1.00" + showMixedAmount (Mixed [(dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}]) `is` "$1.00 @ €2.00" + showMixedAmount (Mixed [dollars 0]) `is` "0" + showMixedAmount (Mixed []) `is` "0" + showMixedAmount missingamt `is` "" - ,"costOfAmount" ~: do - costOfAmount (euros 1) `is` euros 1 - costOfAmount (euros 2){price=Just $ UnitPrice $ Mixed [dollars 2]} `is` dollars 4 - costOfAmount (euros 1){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars 2 - costOfAmount (euros (-1)){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars (-2) + ,"showMixedAmountWithoutPrice" ~: do + let a = (dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]} + showMixedAmountWithoutPrice (Mixed [a]) `is` "$1.00" + showMixedAmountWithoutPrice (Mixed [a, (-a)]) `is` "0" ] diff --git a/Hledger/Data/Commodity.hs b/Hledger/Data/Commodity.hs --- a/Hledger/Data/Commodity.hs +++ b/Hledger/Data/Commodity.hs @@ -8,10 +8,14 @@ -} module Hledger.Data.Commodity where -import Hledger.Data.Utils -import Hledger.Data.Types -import qualified Data.Map as Map +import Data.List import Data.Map ((!)) +import Data.Maybe +import Test.HUnit +import qualified Data.Map as Map + +import Hledger.Data.Types +import Hledger.Utils nonsimplecommoditychars = "0123456789-.@;\n \"" diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -23,13 +23,22 @@ module Hledger.Data.Dates where +import Control.Monad +import Data.List +import Data.Maybe import Data.Time.Format +import Data.Time.Calendar import Data.Time.Calendar.OrdinalDate +import Data.Time.Clock +import Data.Time.LocalTime import Safe (readMay) import System.Locale (defaultTimeLocale) +import Test.HUnit import Text.ParserCombinators.Parsec +import Text.Printf + import Hledger.Data.Types -import Hledger.Data.Utils +import Hledger.Utils showDate :: Day -> String @@ -41,6 +50,12 @@ t <- getZonedTime return $ localDay (zonedTimeToLocalTime t) +-- | Get the current local month number. +getCurrentMonth :: IO Int +getCurrentMonth = do + (_,m,_) <- toGregorian `fmap` getCurrentDay + return m + -- | Get the current local year. getCurrentYear :: IO Integer getCurrentYear = do @@ -106,6 +121,9 @@ parsePeriodExpr :: Day -> String -> Either ParseError (Interval, DateSpan) parsePeriodExpr refdate = parsewith (periodexpr refdate) +maybePeriod :: Day -> String -> Maybe (Interval,DateSpan) +maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate + -- | Show a DateSpan as a human-readable pseudo-period-expression string. dateSpanAsText :: DateSpan -> String dateSpanAsText (DateSpan Nothing Nothing) = "all" @@ -157,14 +175,20 @@ -- | Convert a smart date string to an explicit yyyy\/mm\/dd string using -- the provided reference date, or raise an error. fixSmartDateStr :: Day -> String -> String -fixSmartDateStr t s = either parseerror id $ fixSmartDateStrEither t s +fixSmartDateStr d s = either + (\e->error' $ printf "could not parse date %s %s" (show s) (show e)) + id + $ fixSmartDateStrEither d s -- | A safe version of fixSmartDateStr. fixSmartDateStrEither :: Day -> String -> Either ParseError String -fixSmartDateStrEither t s = case parsewith smartdateonly (lowercase s) of - Right sd -> Right $ showDay $ fixSmartDate t sd - Left e -> Left e +fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d +fixSmartDateStrEither' :: Day -> String -> Either ParseError Day +fixSmartDateStrEither' d s = case parsewith smartdateonly (lowercase s) of + Right sd -> Right $ fixSmartDate d sd + Left e -> Left e + -- | Convert a SmartDate to an absolute date using the provided reference date. fixSmartDate :: Day -> SmartDate -> Day fixSmartDate refdate sdate = fix sdate @@ -537,12 +561,16 @@ d <- smartdate return $ spanFromSmartDate rdate d +-- | Make a datespan from two valid date strings parseable by parsedate +-- (or raise an error). Eg: mkdatespan \"2011/1/1\" \"2011/12/31\". mkdatespan :: String -> String -> DateSpan mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate +nulldatespan :: DateSpan nulldatespan = DateSpan Nothing Nothing -nulldate = parsedate "1900/01/01" +nulldate :: Day +nulldate = parsedate "0000/00/00" tests_Hledger_Data_Dates = TestList [ diff --git a/Hledger/Data/Journal.hs b/Hledger/Data/Journal.hs --- a/Hledger/Data/Journal.hs +++ b/Hledger/Data/Journal.hs @@ -8,11 +8,19 @@ module Hledger.Data.Journal where -import qualified Data.Map as Map +import Data.List import Data.Map (findWithDefault, (!)) +import Data.Ord +import Data.Time.Calendar +import Data.Time.LocalTime +import Data.Tree import Safe (headDef) import System.Time (ClockTime(TOD)) -import Hledger.Data.Utils +import Test.HUnit +import Text.Printf +import qualified Data.Map as Map + +import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName import Hledger.Data.Amount @@ -21,6 +29,7 @@ import Hledger.Data.Transaction (journalTransactionWithDate,balanceTransaction) import Hledger.Data.Posting import Hledger.Data.TimeLog +import Hledger.Data.Matching instance Show Journal where @@ -34,6 +43,18 @@ -- ++ (show $ journalTransactions l) where accounts = flatten $ journalAccountNameTree j +showJournalDebug j = unlines [ + show j + ,show (jtxns j) + ,show (jmodifiertxns j) + ,show (jperiodictxns j) + ,show $ open_timelog_entries j + ,show $ historical_prices j + ,show $ final_comment_lines j + ,show $ jContext j + ,show $ map fst $ files j + ] + nulljournal :: Journal nulljournal = Journal { jmodifiertxns = [] , jperiodictxns = [] @@ -47,17 +68,16 @@ } nullctx :: JournalContext -nullctx = Ctx { ctxYear = Nothing, ctxCommodity = Nothing, ctxAccount = [] } +nullctx = Ctx { ctxYear = Nothing, ctxCommodity = Nothing, ctxAccount = [], ctxAliases = [] } +nullfilterspec :: FilterSpec nullfilterspec = FilterSpec { datespan=nulldatespan ,cleared=Nothing ,real=False ,empty=False - ,costbasis=False ,acctpats=[] ,descpats=[] - ,whichdate=ActualDate ,depth=Nothing } @@ -89,7 +109,7 @@ journalPostings = concatMap tpostings . jtxns journalAccountNamesUsed :: Journal -> [AccountName] -journalAccountNamesUsed = accountNamesFromPostings . journalPostings +journalAccountNamesUsed = sort . accountNamesFromPostings . journalPostings journalAccountNames :: Journal -> [AccountName] journalAccountNames = sort . expandAccountNames . journalAccountNamesUsed @@ -100,38 +120,49 @@ -- Various kinds of filtering on journals. We do it differently depending -- on the command. --- | Keep only transactions we are interested in, as described by --- the filter specification. May also massage the data a little. +------------------------------------------------------------------------------- +-- filtering V2 + +-- | Keep only postings matching the query expression. +-- This can leave unbalanced transactions. +filterJournalPostings2 :: Matcher -> Journal -> Journal +filterJournalPostings2 m j@Journal{jtxns=ts} = j{jtxns=map filtertransactionpostings ts} + where + filtertransactionpostings t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps} + +-- | Keep only transactions matching the query expression. +filterJournalTransactions2 :: Matcher -> Journal -> Journal +filterJournalTransactions2 m j@Journal{jtxns=ts} = j{jtxns=filter (m `matchesTransaction`) ts} + +------------------------------------------------------------------------------- +-- filtering V1 + +-- | Keep only transactions we are interested in, as described by the +-- filter specification. filterJournalTransactions :: FilterSpec -> Journal -> Journal filterJournalTransactions FilterSpec{datespan=datespan ,cleared=cleared -- ,real=real -- ,empty=empty - -- ,costbasis=_ ,acctpats=apats ,descpats=dpats - ,whichdate=whichdate ,depth=depth } = filterJournalTransactionsByClearedStatus cleared . filterJournalPostingsByDepth depth . filterJournalTransactionsByAccount apats . filterJournalTransactionsByDescription dpats . - filterJournalTransactionsByDate datespan . - journalSelectingDate whichdate + filterJournalTransactionsByDate datespan --- | Keep only postings we are interested in, as described by --- the filter specification. May also massage the data a little. --- This can leave unbalanced transactions. +-- | Keep only postings we are interested in, as described by the filter +-- specification. This can leave unbalanced transactions. filterJournalPostings :: FilterSpec -> Journal -> Journal filterJournalPostings FilterSpec{datespan=datespan ,cleared=cleared ,real=real ,empty=empty --- ,costbasis=costbasis ,acctpats=apats ,descpats=dpats - ,whichdate=whichdate ,depth=depth } = filterJournalPostingsByRealness real . @@ -140,8 +171,7 @@ filterJournalPostingsByDepth depth . filterJournalPostingsByAccount apats . filterJournalTransactionsByDescription dpats . - filterJournalTransactionsByDate datespan . - journalSelectingDate whichdate + filterJournalTransactionsByDate datespan -- | Keep only transactions whose description matches the description patterns. filterJournalTransactionsByDescription :: [String] -> Journal -> Journal @@ -208,7 +238,7 @@ tmatch t = (null positives || any positivepmatch ps) && (null negatives || not (any negativepmatch ps)) where ps = tpostings t positivepmatch p = any (`amatch` a) positives where a = paccount p negativepmatch p = any (`amatch` a) negatives where a = paccount p - amatch pat a = containsRegex (abspat pat) a + amatch pat a = regexMatchesCI (abspat pat) a (negatives,positives) = partition isnegativepat apats -- | Keep only postings which affect accounts matched by the account patterns. @@ -224,6 +254,13 @@ journalSelectingDate EffectiveDate j = j{jtxns=map (journalTransactionWithDate EffectiveDate) $ jtxns j} +-- | Apply additional account aliases (eg from the command-line) to all postings in a journal. +journalApplyAliases :: [(AccountName,AccountName)] -> Journal -> Journal +journalApplyAliases aliases j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} + where + fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps} + fixposting p@Posting{paccount=a} = p{paccount=accountNameApplyAliases aliases a} + -- | Do post-parse processing on a journal, to make it ready for use. journalFinalise :: ClockTime -> LocalTime -> FilePath -> String -> JournalContext -> Journal -> Either String Journal journalFinalise tclock tlocal path txt ctx j@Journal{files=fs} = @@ -291,7 +328,7 @@ fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps} fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a} fixmixedamount (Mixed as) = Mixed $ map fixamount as - fixamount = canonicaliseAmount (Just $ journalCanonicalCommodities j) . costOfAmount + fixamount = canonicaliseAmountCommodity (Just $ journalCanonicalCommodities j) . costOfAmount -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol. journalCanonicalCommodities :: Journal -> Map.Map String Commodity @@ -334,7 +371,7 @@ where (negatives,positives) = partition isnegativepat pats match "" = True - match pat = containsRegex (abspat pat) str + match pat = regexMatchesCI (abspat pat) str negateprefix = "not:" @@ -389,6 +426,10 @@ sortedps = sortBy (comparing paccount) ps groupedps = groupBy (\p1 p2 -> paccount p1 == paccount p2) sortedps m' = Map.fromList [(paccount $ head g, g) | g <- groupedps] + +-- debug helpers +traceAmountPrecision a = trace (show $ map (precision . commodity) $ amounts a) a +tracePostingsCommodities ps = trace (show $ map ((map (precision . commodity) . amounts) . pamount) ps) ps tests_Hledger_Data_Journal = TestList [ ] diff --git a/Hledger/Data/Ledger.hs b/Hledger/Data/Ledger.hs --- a/Hledger/Data/Ledger.hs +++ b/Hledger/Data/Ledger.hs @@ -10,12 +10,17 @@ module Hledger.Data.Ledger where import Data.Map (Map, findWithDefault, fromList) -import Hledger.Data.Utils +import Data.Tree +import Test.HUnit +import Text.Printf + +import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Account (nullacct) import Hledger.Data.AccountName import Hledger.Data.Journal import Hledger.Data.Posting +import Hledger.Data.Matching instance Show Ledger where @@ -41,6 +46,15 @@ where j' = filterJournalPostings fs{depth=Nothing} j (t, m) = journalAccountInfo j' +-- | Filter a journal's transactions as specified, and then process them +-- to derive a ledger containing all balances, the chart of accounts, +-- canonicalised commodities etc. +-- Like journalToLedger but uses the new matchers. +journalToLedger2 :: Matcher -> Journal -> Ledger +journalToLedger2 m j = nullledger{journal=j',accountnametree=t,accountmap=amap} + where j' = filterJournalPostings2 m j + (t, amap) = journalAccountInfo j' + -- | List a ledger's account names. ledgerAccountNames :: Ledger -> [AccountName] ledgerAccountNames = drop 1 . flatten . accountnametree @@ -56,6 +70,10 @@ -- | List a ledger's top-level accounts, in tree order ledgerTopAccounts :: Ledger -> [Account] ledgerTopAccounts = map root . branches . ledgerAccountTree 9999 + +-- | List a ledger's bottom-level (subaccount-less) accounts, in tree order +ledgerLeafAccounts :: Ledger -> [Account] +ledgerLeafAccounts = leaves . ledgerAccountTree 9999 -- | Accounts in ledger whose name matches the pattern, in tree order. ledgerAccountsMatching :: [String] -> Ledger -> [Account] diff --git a/Hledger/Data/Matching.hs b/Hledger/Data/Matching.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Matching.hs @@ -0,0 +1,317 @@ +{-| + +More generic matching, done in one step, unlike FilterSpec and filterJournal*. +Currently used only by hledger-web. + +-} + +module Hledger.Data.Matching +where +import Data.Either +import Data.List +-- import Data.Map (findWithDefault, (!)) +import Data.Maybe +-- import Data.Ord +import Data.Time.Calendar +-- import Data.Time.LocalTime +-- import Data.Tree +import Safe (readDef, headDef) +-- import System.Time (ClockTime(TOD)) +import Test.HUnit +import Text.ParserCombinators.Parsec +-- import Text.Printf +-- import qualified Data.Map as Map + +import Hledger.Utils +import Hledger.Data.Types +import Hledger.Data.AccountName +import Hledger.Data.Amount +-- import Hledger.Data.Commodity (canonicaliseCommodities) +import Hledger.Data.Dates +import Hledger.Data.Posting +import Hledger.Data.Transaction +-- import Hledger.Data.TimeLog + +-- | A matcher is a single, or boolean composition of, search criteria, +-- which can be used to match postings, transactions, accounts and more. +-- Currently used by hledger-web, will likely replace FilterSpec at some point. +data Matcher = MatchAny -- ^ always match + | MatchNone -- ^ never match + | MatchNot Matcher -- ^ negate this match + | MatchOr [Matcher] -- ^ match if any of these match + | MatchAnd [Matcher] -- ^ match if all of these match + | MatchDesc String -- ^ match if description matches this regexp + | MatchAcct String -- ^ match postings whose account matches this regexp + | MatchDate DateSpan -- ^ match if actual date in this date span + | MatchEDate DateSpan -- ^ match if effective date in this date span + | MatchStatus Bool -- ^ match if cleared status has this value + | MatchReal Bool -- ^ match if "realness" (involves a real non-virtual account ?) has this value + | MatchEmpty Bool -- ^ match if "emptiness" (from the --empty command-line flag) has this value. + -- Currently this means a posting with zero amount. + | MatchDepth Int -- ^ match if account depth is less than or equal to this value + deriving (Show, Eq) + +-- | A query option changes a query's/report's behaviour and output in some way. + +-- XXX could use regular CliOpts ? +data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register focussed on this account + | QueryOptInAcct AccountName -- ^ as above but include sub-accounts in the account register + -- | QueryOptCostBasis -- ^ show amounts converted to cost where possible + -- | QueryOptEffectiveDate -- ^ show effective dates instead of actual dates + deriving (Show, Eq) + +-- | The account we are currently focussed on, if any, and whether subaccounts are included. +-- Just looks at the first query option. +inAccount :: [QueryOpt] -> Maybe (AccountName,Bool) +inAccount [] = Nothing +inAccount (QueryOptInAcctOnly a:_) = Just (a,False) +inAccount (QueryOptInAcct a:_) = Just (a,True) + +-- | A matcher for the account(s) we are currently focussed on, if any. +-- Just looks at the first query option. +inAccountMatcher :: [QueryOpt] -> Maybe Matcher +inAccountMatcher [] = Nothing +inAccountMatcher (QueryOptInAcctOnly a:_) = Just $ MatchAcct $ accountNameToAccountOnlyRegex a +inAccountMatcher (QueryOptInAcct a:_) = Just $ MatchAcct $ accountNameToAccountRegex a + +-- -- | A matcher restricting the account(s) to be shown in the sidebar, if any. +-- -- Just looks at the first query option. +-- showAccountMatcher :: [QueryOpt] -> Maybe Matcher +-- showAccountMatcher (QueryOptInAcctSubsOnly a:_) = Just $ MatchAcct True $ accountNameToAccountRegex a +-- showAccountMatcher _ = Nothing + +-- | Convert a query expression containing zero or more space-separated +-- terms to a matcher and zero or more query options. A query term is either: +-- +-- 1. a search criteria, used to match transactions. This is usually a prefixed pattern such as: +-- acct:REGEXP +-- date:PERIODEXP +-- not:desc:REGEXP +-- +-- 2. a query option, which changes behaviour in some way. There is currently one of these: +-- inacct:FULLACCTNAME - should appear only once +-- +-- Multiple search criteria are AND'ed together. +-- When a pattern contains spaces, it or the whole term should be enclosed in single or double quotes. +-- A reference date is required to interpret relative dates in period expressions. +-- +parseQuery :: Day -> String -> (Matcher,[QueryOpt]) +parseQuery d s = (m,qopts) + where + terms = words'' prefixes s + (matchers, qopts) = partitionEithers $ map (parseMatcher d) terms + m = case matchers of [] -> MatchAny + (m':[]) -> m' + ms -> MatchAnd ms + +-- | Quote-and-prefix-aware version of words - don't split on spaces which +-- are inside quotes, including quotes which may have one of the specified +-- prefixes in front, and maybe an additional not: prefix in front of that. +words'' :: [String] -> String -> [String] +words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX + where + maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, quotedPattern, pattern] `sepBy` many1 spacenonewline + prefixedQuotedPattern = do + not' <- optionMaybe $ string "not:" + prefix <- choice' $ map string prefixes + p <- quotedPattern + return $ fromMaybe "" not' ++ prefix ++ stripquotes p + quotedPattern = do + p <- between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\"" + return $ stripquotes p + pattern = many (noneOf " \n\r\"") + +-- -- | Parse the query string as a boolean tree of match patterns. +-- parseMatcher :: String -> Matcher +-- parseMatcher s = either (const (MatchAny)) id $ runParser matcher () "" $ lexmatcher s + +-- lexmatcher :: String -> [String] +-- lexmatcher s = words' s + +-- matcher :: GenParser String () Matcher +-- matcher = undefined + +-- keep synced with patterns below, excluding "not" +prefixes = map (++":") [ + "inacct","inacctonly", + "desc","acct","date","edate","status","real","empty","depth" + ] +defaultprefix = "acct" + +-- | Parse a single query term as either a matcher or a query option. +parseMatcher :: Day -> String -> Either Matcher QueryOpt +parseMatcher _ ('i':'n':'a':'c':'c':'t':'o':'n':'l':'y':':':s) = Right $ QueryOptInAcctOnly s +parseMatcher _ ('i':'n':'a':'c':'c':'t':':':s) = Right $ QueryOptInAcct s +parseMatcher d ('n':'o':'t':':':s) = case parseMatcher d s of + Left m -> Left $ MatchNot m + Right _ -> Left MatchAny -- not:somequeryoption will be ignored +parseMatcher _ ('d':'e':'s':'c':':':s) = Left $ MatchDesc s +parseMatcher _ ('a':'c':'c':'t':':':s) = Left $ MatchAcct s +parseMatcher d ('d':'a':'t':'e':':':s) = + case parsePeriodExpr d s of Left _ -> Left MatchNone -- XXX should warn + Right (_,span) -> Left $ MatchDate span +parseMatcher d ('e':'d':'a':'t':'e':':':s) = + case parsePeriodExpr d s of Left _ -> Left MatchNone -- XXX should warn + Right (_,span) -> Left $ MatchEDate span +parseMatcher _ ('s':'t':'a':'t':'u':'s':':':s) = Left $ MatchStatus $ parseStatus s +parseMatcher _ ('r':'e':'a':'l':':':s) = Left $ MatchReal $ parseBool s +parseMatcher _ ('e':'m':'p':'t':'y':':':s) = Left $ MatchEmpty $ parseBool s +parseMatcher _ ('d':'e':'p':'t':'h':':':s) = Left $ MatchDepth $ readDef 0 s +parseMatcher _ "" = Left $ MatchAny +parseMatcher d s = parseMatcher d $ defaultprefix++":"++s + +-- | Parse the boolean value part of a "status:" matcher, allowing "*" as +-- another way to spell True, similar to the journal file format. +parseStatus :: String -> Bool +parseStatus s = s `elem` (truestrings ++ ["*"]) + +-- | Parse the boolean value part of a "status:" matcher. A true value can +-- be spelled as "1", "t" or "true". +parseBool :: String -> Bool +parseBool s = s `elem` truestrings + +truestrings :: [String] +truestrings = ["1","t","true"] + +-- | Convert a match expression to its inverse. +negateMatcher :: Matcher -> Matcher +negateMatcher = MatchNot + +-- | Does the match expression match this posting ? +matchesPosting :: Matcher -> Posting -> Bool +matchesPosting (MatchNot m) p = not $ matchesPosting m p +matchesPosting (MatchAny) _ = True +matchesPosting (MatchNone) _ = False +matchesPosting (MatchOr ms) p = any (`matchesPosting` p) ms +matchesPosting (MatchAnd ms) p = all (`matchesPosting` p) ms +matchesPosting (MatchDesc r) p = regexMatchesCI r $ maybe "" tdescription $ ptransaction p +matchesPosting (MatchAcct r) p = regexMatchesCI r $ paccount p +matchesPosting (MatchDate span) p = + case d of Just d' -> spanContainsDate span d' + Nothing -> False + where d = maybe Nothing (Just . tdate) $ ptransaction p +matchesPosting (MatchEDate span) p = + case postingEffectiveDate p of Just d -> spanContainsDate span d + Nothing -> False +matchesPosting (MatchStatus v) p = v == postingCleared p +matchesPosting (MatchReal v) p = v == isReal p +matchesPosting (MatchEmpty v) Posting{pamount=a} = v == isZeroMixedAmount a +matchesPosting _ _ = False + +-- | Does the match expression match this transaction ? +matchesTransaction :: Matcher -> Transaction -> Bool +matchesTransaction (MatchNot m) t = not $ matchesTransaction m t +matchesTransaction (MatchAny) _ = True +matchesTransaction (MatchNone) _ = False +matchesTransaction (MatchOr ms) t = any (`matchesTransaction` t) ms +matchesTransaction (MatchAnd ms) t = all (`matchesTransaction` t) ms +matchesTransaction (MatchDesc r) t = regexMatchesCI r $ tdescription t +matchesTransaction m@(MatchAcct _) t = any (m `matchesPosting`) $ tpostings t +matchesTransaction (MatchDate span) t = spanContainsDate span $ tdate t +matchesTransaction (MatchEDate span) t = spanContainsDate span $ transactionEffectiveDate t +matchesTransaction (MatchStatus v) t = v == tstatus t +matchesTransaction (MatchReal v) t = v == hasRealPostings t +matchesTransaction _ _ = False + +postingEffectiveDate :: Posting -> Maybe Day +postingEffectiveDate p = maybe Nothing (Just . transactionEffectiveDate) $ ptransaction p + +transactionEffectiveDate :: Transaction -> Day +transactionEffectiveDate t = case teffectivedate t of Just d -> d + Nothing -> tdate t + +-- | Does the match expression match this account ? +-- A matching in: clause is also considered a match. +matchesAccount :: Matcher -> AccountName -> Bool +matchesAccount (MatchNot m) a = not $ matchesAccount m a +matchesAccount (MatchAny) _ = True +matchesAccount (MatchNone) _ = False +matchesAccount (MatchOr ms) a = any (`matchesAccount` a) ms +matchesAccount (MatchAnd ms) a = all (`matchesAccount` a) ms +matchesAccount (MatchAcct r) a = regexMatchesCI r a +matchesAccount _ _ = False + +-- | What start date does this matcher specify, if any ? +-- If the matcher is an OR expression, returns the earliest of the alternatives. +-- When the flag is true, look for a starting effective date instead. +matcherStartDate :: Bool -> Matcher -> Maybe Day +matcherStartDate effective (MatchOr ms) = earliestMaybeDate $ map (matcherStartDate effective) ms +matcherStartDate effective (MatchAnd ms) = latestMaybeDate $ map (matcherStartDate effective) ms +matcherStartDate False (MatchDate (DateSpan (Just d) _)) = Just d +matcherStartDate True (MatchEDate (DateSpan (Just d) _)) = Just d +matcherStartDate _ _ = Nothing + +-- | Does this matcher specify a start date and nothing else (that would +-- filter postings prior to the date) ? +-- When the flag is true, look for a starting effective date instead. +matcherIsStartDateOnly :: Bool -> Matcher -> Bool +matcherIsStartDateOnly _ MatchAny = False +matcherIsStartDateOnly _ MatchNone = False +matcherIsStartDateOnly effective (MatchOr ms) = and $ map (matcherIsStartDateOnly effective) ms +matcherIsStartDateOnly effective (MatchAnd ms) = and $ map (matcherIsStartDateOnly effective) ms +matcherIsStartDateOnly False (MatchDate (DateSpan (Just _) _)) = True +matcherIsStartDateOnly True (MatchEDate (DateSpan (Just _) _)) = True +matcherIsStartDateOnly _ _ = False + +-- | Does this matcher match everything ? +matcherIsNull MatchAny = True +matcherIsNull (MatchAnd []) = True +matcherIsNull (MatchNot (MatchOr [])) = True +matcherIsNull _ = False + +-- | What is the earliest of these dates, where Nothing is earliest ? +earliestMaybeDate :: [Maybe Day] -> Maybe Day +earliestMaybeDate = headDef Nothing . sortBy compareMaybeDates + +-- | What is the latest of these dates, where Nothing is earliest ? +latestMaybeDate :: [Maybe Day] -> Maybe Day +latestMaybeDate = headDef Nothing . sortBy (flip compareMaybeDates) + +-- | Compare two maybe dates, Nothing is earliest. +compareMaybeDates :: Maybe Day -> Maybe Day -> Ordering +compareMaybeDates Nothing Nothing = EQ +compareMaybeDates Nothing (Just _) = LT +compareMaybeDates (Just _) Nothing = GT +compareMaybeDates (Just a) (Just b) = compare a b + +tests_Hledger_Data_Matching :: Test +tests_Hledger_Data_Matching = TestList + [ + + "parseQuery" ~: do + let d = parsedate "2011/1/1" + parseQuery d "a" `is` (MatchAcct "a", []) + parseQuery d "acct:a" `is` (MatchAcct "a", []) + parseQuery d "acct:a desc:b" `is` (MatchAnd [MatchAcct "a", MatchDesc "b"], []) + parseQuery d "\"acct:expenses:autres d\233penses\"" `is` (MatchAcct "expenses:autres d\233penses", []) + parseQuery d "not:desc:'a b'" `is` (MatchNot $ MatchDesc "a b", []) + + parseQuery d "inacct:a desc:b" `is` (MatchDesc "b", [QueryOptInAcct "a"]) + parseQuery d "inacct:a inacct:b" `is` (MatchAny, [QueryOptInAcct "a", QueryOptInAcct "b"]) + + parseQuery d "status:1" `is` (MatchStatus True, []) + parseQuery d "status:0" `is` (MatchStatus False, []) + parseQuery d "status:" `is` (MatchStatus False, []) + parseQuery d "real:1" `is` (MatchReal True, []) + + ,"matchesAccount" ~: do + assertBool "positive acct match" $ matchesAccount (MatchAcct "b:c") "a:bb:c:d" + -- assertBool "acct should match at beginning" $ not $ matchesAccount (MatchAcct True "a:b") "c:a:b" + + ,"matchesPosting" ~: do + -- matching posting status.. + assertBool "positive match on true posting status" $ + (MatchStatus True) `matchesPosting` nullposting{pstatus=True} + assertBool "negative match on true posting status" $ + not $ (MatchNot $ MatchStatus True) `matchesPosting` nullposting{pstatus=True} + assertBool "positive match on false posting status" $ + (MatchStatus False) `matchesPosting` nullposting{pstatus=False} + assertBool "negative match on false posting status" $ + not $ (MatchNot $ MatchStatus False) `matchesPosting` nullposting{pstatus=False} + assertBool "positive match on true posting status acquired from transaction" $ + (MatchStatus True) `matchesPosting` nullposting{pstatus=False,ptransaction=Just nulltransaction{tstatus=True}} + assertBool "real:1 on real posting" $ (MatchReal True) `matchesPosting` nullposting{ptype=RegularPosting} + assertBool "real:1 on virtual posting fails" $ not $ (MatchReal True) `matchesPosting` nullposting{ptype=VirtualPosting} + assertBool "real:1 on balanced virtual posting fails" $ not $ (MatchReal True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting} + + ] diff --git a/Hledger/Data/Posting.hs b/Hledger/Data/Posting.hs --- a/Hledger/Data/Posting.hs +++ b/Hledger/Data/Posting.hs @@ -10,7 +10,14 @@ module Hledger.Data.Posting where -import Hledger.Data.Utils +import Data.List +import Data.Ord +import Data.Time.Calendar +import Safe +import Test.HUnit +import Text.Printf + +import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Amount import Hledger.Data.AccountName @@ -19,6 +26,7 @@ instance Show Posting where show = showPosting +nullposting :: Posting nullposting = Posting False "" nullmixedamt "" RegularPosting [] Nothing showPosting :: Posting -> String @@ -32,7 +40,7 @@ BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2) VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2) _ -> (id,acctnamewidth) - showamount = padleft 12 . showMixedAmountOrZero + showamount = padleft 12 . showMixedAmount comment = if null com then "" else " ; " ++ com -- XXX refactor showPostingForRegister :: Posting -> String @@ -46,7 +54,7 @@ BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2) VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2) _ -> (id,acctnamewidth) - showamount = padleft 12 . showMixedAmountOrZeroWithoutPrice + showamount = padleft 12 . showMixedAmountWithoutPrice isReal :: Posting -> Bool isReal p = ptype p == RegularPosting @@ -60,16 +68,11 @@ hasAmount :: Posting -> Bool hasAmount = (/= missingamt) . pamount -postingTypeFromAccountName a - | head a == '[' && last a == ']' = BalancedVirtualPosting - | head a == '(' && last a == ')' = VirtualPosting - | otherwise = RegularPosting - accountNamesFromPostings :: [Posting] -> [AccountName] accountNamesFromPostings = nub . map paccount sumPostings :: [Posting] -> MixedAmount -sumPostings = sumMixedAmountsPreservingHighestPrecision . map pamount +sumPostings = sum . map pamount postingDate :: Posting -> Day postingDate p = maybe nulldate tdate $ ptransaction p @@ -97,6 +100,69 @@ postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps') where ps' = sortBy (comparing postingDate) ps +-- AccountName stuff that depends on PostingType + +accountNamePostingType :: AccountName -> PostingType +accountNamePostingType a + | null a = RegularPosting + | head a == '[' && last a == ']' = BalancedVirtualPosting + | head a == '(' && last a == ')' = VirtualPosting + | otherwise = RegularPosting + +accountNameWithoutPostingType :: AccountName -> AccountName +accountNameWithoutPostingType a = case accountNamePostingType a of + BalancedVirtualPosting -> init $ tail a + VirtualPosting -> init $ tail a + RegularPosting -> a + +accountNameWithPostingType :: PostingType -> AccountName -> AccountName +accountNameWithPostingType BalancedVirtualPosting a = "["++accountNameWithoutPostingType a++"]" +accountNameWithPostingType VirtualPosting a = "("++accountNameWithoutPostingType a++")" +accountNameWithPostingType RegularPosting a = accountNameWithoutPostingType a + +-- | Prefix one account name to another, preserving posting type +-- indicators like concatAccountNames. +joinAccountNames :: AccountName -> AccountName -> AccountName +joinAccountNames a b = concatAccountNames $ filter (not . null) [a,b] + +-- | Join account names into one. If any of them has () or [] posting type +-- indicators, these (the first type encountered) will also be applied to +-- the resulting account name. +concatAccountNames :: [AccountName] -> AccountName +concatAccountNames as = accountNameWithPostingType t $ intercalate ":" $ map accountNameWithoutPostingType as + where t = headDef RegularPosting $ filter (/= RegularPosting) $ map accountNamePostingType as + +-- | Rewrite an account name using the first applicable alias from the given list, if any. +accountNameApplyAliases :: [(AccountName,AccountName)] -> AccountName -> AccountName +accountNameApplyAliases aliases a = withorigtype + where + (a',t) = (accountNameWithoutPostingType a, accountNamePostingType a) + firstmatchingalias = headDef Nothing $ map Just $ filter (\(orig,_) -> orig == a' || orig `isAccountNamePrefixOf` a') aliases + rewritten = maybe a' (\(orig,alias) -> alias++drop (length orig) a') firstmatchingalias + withorigtype = accountNameWithPostingType t rewritten + tests_Hledger_Data_Posting = TestList [ + + "accountNamePostingType" ~: do + accountNamePostingType "a" `is` RegularPosting + accountNamePostingType "(a)" `is` VirtualPosting + accountNamePostingType "[a]" `is` BalancedVirtualPosting + + ,"accountNameWithoutPostingType" ~: do + accountNameWithoutPostingType "(a)" `is` "a" + + ,"accountNameWithPostingType" ~: do + accountNameWithPostingType VirtualPosting "[a]" `is` "(a)" + + ,"joinAccountNames" ~: do + "a" `joinAccountNames` "b:c" `is` "a:b:c" + "a" `joinAccountNames` "(b:c)" `is` "(a:b:c)" + "[a]" `joinAccountNames` "(b:c)" `is` "[a:b:c]" + "" `joinAccountNames` "a" `is` "a" + + ,"concatAccountNames" ~: do + concatAccountNames [] `is` "" + concatAccountNames ["a","(b)","[c:d]"] `is` "(a:b:c:d)" + ] diff --git a/Hledger/Data/TimeLog.hs b/Hledger/Data/TimeLog.hs --- a/Hledger/Data/TimeLog.hs +++ b/Hledger/Data/TimeLog.hs @@ -8,9 +8,16 @@ module Hledger.Data.TimeLog where +import Data.Maybe +import Data.Time.Calendar +import Data.Time.Clock import Data.Time.Format +import Data.Time.LocalTime import System.Locale (defaultTimeLocale) -import Hledger.Data.Utils +import Test.HUnit +import Text.Printf + +import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Dates import Hledger.Data.Commodity diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -8,9 +8,13 @@ module Hledger.Data.Transaction where +import Data.List +import Data.Maybe +import Test.HUnit +import Text.Printf import qualified Data.Map as Map -import Hledger.Data.Utils +import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Dates import Hledger.Data.Posting @@ -91,7 +95,7 @@ where w = maximum $ map (length . paccount) ps showstatus p = if pstatus p then "* " else "" showamt = - padleft 12 . showMixedAmountOrZero + padleft 12 . showMixedAmount showcomment s = if null s then "" else " ; "++s -- | Show an account name, clipped to the given width if any, and @@ -106,6 +110,9 @@ parenthesise s = "("++s++")" bracket s = "["++s++"]" +hasRealPostings :: Transaction -> Bool +hasRealPostings = not . null . realPostings + realPostings :: Transaction -> [Posting] realPostings = filter isReal . tpostings @@ -115,6 +122,9 @@ balancedVirtualPostings :: Transaction -> [Posting] balancedVirtualPostings = filter isBalancedVirtual . tpostings +transactionsPostings :: [Transaction] -> [Posting] +transactionsPostings = concat . map tpostings + -- | Get the sums of a transaction's real, virtual, and balanced virtual postings. transactionPostingBalances :: Transaction -> (MixedAmount,MixedAmount,MixedAmount) transactionPostingBalances t = (sumPostings $ realPostings t @@ -130,8 +140,8 @@ isZeroMixedAmount rsum' && isZeroMixedAmount bvsum' where (rsum, _, bvsum) = transactionPostingBalances t - rsum' = canonicaliseMixedAmount canonicalcommoditymap $ costOfMixedAmount rsum - bvsum' = canonicaliseMixedAmount canonicalcommoditymap $ costOfMixedAmount bvsum + rsum' = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount rsum + bvsum' = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount bvsum -- | Ensure this transaction is balanced, possibly inferring a missing -- amount or a conversion price first, or return an error message. @@ -179,9 +189,10 @@ where conversionprice c | c == unpricedcommodity -- assign a balancing price. Use @@ for more exact output when possible. + -- invariant: prices should always be positive. Enforced with "abs" = if length ramountsinunpricedcommodity == 1 - then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ negate $ targetcommodityamount] - else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ negate $ targetcommodityamount `divideAmount` (quantity unpricedamount)] + then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount] + else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (quantity unpricedamount)] | otherwise = Nothing where unpricedcommodity = head $ filter (`elem` (map commodity rsumamounts)) rcommoditiesinorder @@ -204,8 +215,8 @@ where conversionprice c | c == unpricedcommodity = if length bvamountsinunpricedcommodity == 1 - then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ negate $ targetcommodityamount] - else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ negate $ targetcommodityamount `divideAmount` (quantity unpricedamount)] + then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount] + else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (quantity unpricedamount)] | otherwise = Nothing where unpricedcommodity = head $ filter (`elem` (map commodity bvsumamounts)) bvcommoditiesinorder diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -4,15 +4,15 @@ Most data types are defined here to avoid import cycles. Here is an overview of the hledger data model: -> Journal -- a journal is derived from one or more data files. It contains.. -> [Transaction] -- journal transactions, which have date, status, code, description and.. -> [Posting] -- multiple account postings (entries), which have account name and amount. +> Journal -- a journal is read from one or more data files. It contains.. +> [Transaction] -- journal transactions (aka entries), which have date, status, code, description and.. +> [Posting] -- multiple account postings, which have account name and amount > [HistoricalPrice] -- historical commodity prices > > Ledger -- a ledger is derived from a journal, by applying a filter specification and doing some further processing. It contains.. -> Journal -- the filtered journal, containing only the transactions and postings we are interested in -> Tree AccountName -- account names referenced in the journal's transactions, as a tree -> Map AccountName Account -- per-account postings and balances from the journal's transactions, as a map from account name to account info +> Journal -- a filtered copy of the original journal, containing only the transactions and postings we are interested in +> Tree AccountName -- all accounts named by the journal's transactions, as a hierarchy +> Map AccountName Account -- the postings, and resulting balances, in each account For more detailed documentation on each type, see the corresponding modules. @@ -33,13 +33,14 @@ module Hledger.Data.Types where import Control.Monad.Error (ErrorT) -import Data.Typeable (Typeable) +import Data.Time.Calendar +import Data.Time.LocalTime +import Data.Tree +import Data.Typeable import qualified Data.Map as Map import System.Time (ClockTime) -import Hledger.Data.Utils - type SmartDate = (String,String,String) data WhichDate = ActualDate | EffectiveDate deriving (Eq,Show) @@ -68,9 +69,10 @@ separatorpositions :: [Int] -- ^ positions of separators, counting leftward from decimal point } deriving (Eq,Ord,Show,Read) --- | An amount's price may be written as \@ unit price or \@\@ total price. --- Note although Price has a MixedAmount, it should hold only --- single-commodity amounts, cf costOfAmount. +-- | An amount's price in another commodity may be written as \@ unit +-- price or \@\@ total price. Note although a MixedAmount is used, it +-- should be in a single commodity, also the amount should be positive; +-- these are not enforced currently. data Price = UnitPrice MixedAmount | TotalPrice MixedAmount deriving (Eq,Ord) @@ -146,7 +148,10 @@ data JournalContext = Ctx { ctxYear :: !(Maybe Year) -- ^ the default year most recently specified with Y , ctxCommodity :: !(Maybe Commodity) -- ^ the default commodity most recently specified with D - , ctxAccount :: ![AccountName] -- ^ the current stack of parent accounts specified by !account + , ctxAccount :: ![AccountName] -- ^ the current stack of parent accounts/account name components + -- specified with "account" directive(s). Concatenated, these + -- are the account prefix prepended to parsed account names. + , ctxAliases :: ![(AccountName,AccountName)] -- ^ the current list of account name aliases in effect } deriving (Read, Show, Eq) data Journal = Journal { @@ -187,16 +192,14 @@ abalance :: MixedAmount -- ^ sum of postings in this account and subaccounts } --- | A generic, pure specification of how to filter transactions and postings. +-- | A generic, pure specification of how to filter (or search) transactions and postings. data FilterSpec = FilterSpec { datespan :: DateSpan -- ^ only include if in this date span ,cleared :: Maybe Bool -- ^ only include if cleared\/uncleared\/don't care ,real :: Bool -- ^ only include if real\/don't care ,empty :: Bool -- ^ include if empty (ie amount is zero) - ,costbasis :: Bool -- ^ convert all amounts to cost basis ,acctpats :: [String] -- ^ only include if matching these account patterns ,descpats :: [String] -- ^ only include if matching these description patterns - ,whichdate :: WhichDate -- ^ which dates to use (actual or effective) ,depth :: Maybe Int } deriving (Show) diff --git a/Hledger/Data/UTF8.hs b/Hledger/Data/UTF8.hs deleted file mode 100644 --- a/Hledger/Data/UTF8.hs +++ /dev/null @@ -1,83 +0,0 @@ -{- -From pandoc, slightly extended. - ----------------------------------------------------------------------- -Copyright (C) 2010 John MacFarlane - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- | - Module : Text.Pandoc.UTF8 - Copyright : Copyright (C) 2010 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane - Stability : alpha - Portability : portable - -UTF-8 aware string IO functions that will work with GHC 6.10 or 6.12. --} -module Hledger.Data.UTF8 ( readFile - , writeFile - , appendFile - , getContents - , hGetContents - , putStr - , putStrLn - , hPutStr - , hPutStrLn - ) - -where -import qualified Data.ByteString.Lazy as B -import Data.ByteString.Lazy.UTF8 (toString, fromString) -import Prelude hiding (readFile, writeFile, appendFile, getContents, putStr, putStrLn) -import System.IO (Handle) -import Control.Monad (liftM) - -bom :: B.ByteString -bom = B.pack [0xEF, 0xBB, 0xBF] - -stripBOM :: B.ByteString -> B.ByteString -stripBOM s | bom `B.isPrefixOf` s = B.drop 3 s -stripBOM s = s - -readFile :: FilePath -> IO String -readFile = liftM (toString . stripBOM) . B.readFile - -writeFile :: FilePath -> String -> IO () -writeFile f = B.writeFile f . fromString - -appendFile :: FilePath -> String -> IO () -appendFile f = B.appendFile f . fromString - -getContents :: IO String -getContents = liftM (toString . stripBOM) B.getContents - -hGetContents :: Handle -> IO String -hGetContents h = liftM (toString . stripBOM) (B.hGetContents h) - -putStr :: String -> IO () -putStr = B.putStr . fromString - -putStrLn :: String -> IO () -putStrLn = B.putStrLn . fromString - -hPutStr :: Handle -> String -> IO () -hPutStr h = B.hPutStr h . fromString - -hPutStrLn :: Handle -> String -> IO () -hPutStrLn h s = hPutStr h (s ++ "\n") diff --git a/Hledger/Data/Utils.hs b/Hledger/Data/Utils.hs deleted file mode 100644 --- a/Hledger/Data/Utils.hs +++ /dev/null @@ -1,376 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| - -Standard imports and utilities which are useful everywhere, or needed low -in the module hierarchy. This is the bottom of hledger's module graph. - --} - -module Hledger.Data.Utils ( -module Data.Char, -module Control.Monad, -module Data.List, ---module Data.Map, -module Data.Maybe, -module Data.Ord, -module Data.Tree, -module Data.Time.Clock, -module Data.Time.Calendar, -module Data.Time.LocalTime, -module Debug.Trace, -module Hledger.Data.Utils, --- module Hledger.Data.UTF8, -module Text.Printf, -module Text.RegexPR, -module Test.HUnit, -) -where -import Data.Char -import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded) -import Control.Monad -import Data.List ---import qualified Data.Map as Map -import Data.Maybe -import Data.Ord -import Data.Tree -import Data.Time.Clock -import Data.Time.Calendar -import Data.Time.LocalTime -import Debug.Trace --- needs to be done in each module I think --- import Prelude hiding (readFile,writeFile,getContents,putStr,putStrLn) --- import Hledger.Data.UTF8 -import Test.HUnit -import Text.Printf -import Text.RegexPR -import Text.ParserCombinators.Parsec -import System.Info (os) - - --- strings - -lowercase = map toLower -uppercase = map toUpper - -strip = lstrip . rstrip -lstrip = dropws -rstrip = reverse . dropws . reverse -dropws = dropWhile (`elem` " \t") - -elideLeft width s = - if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s - -elideRight width s = - if length s > width then take (width - 2) s ++ ".." else s - -underline :: String -> String -underline s = s' ++ replicate (length s) '-' ++ "\n" - where s' - | last s == '\n' = s - | otherwise = s ++ "\n" - -unbracket :: String -> String -unbracket s - | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s - | otherwise = s - --- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded. -concatTopPadded :: [String] -> String -concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded - where - lss = map lines strs - h = maximum $ map length lss - ypad ls = replicate (difforzero h (length ls)) "" ++ ls - xpad ls = map (padleft w) ls where w | null ls = 0 - | otherwise = maximum $ map length ls - padded = map (xpad . ypad) lss - --- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded. -concatBottomPadded :: [String] -> String -concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded - where - lss = map lines strs - h = maximum $ map length lss - ypad ls = ls ++ replicate (difforzero h (length ls)) "" - xpad ls = map (padleft w) ls where w | null ls = 0 - | otherwise = maximum $ map length ls - padded = map (xpad . ypad) lss - --- | Compose strings vertically and right-aligned. -vConcatRightAligned :: [String] -> String -vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss - where - showfixedwidth = printf (printf "%%%ds" width) - width = maximum $ map length ss - --- | Convert a multi-line string to a rectangular string top-padded to the specified height. -padtop :: Int -> String -> String -padtop h s = intercalate "\n" xpadded - where - ls = lines s - sh = length ls - sw | null ls = 0 - | otherwise = maximum $ map length ls - ypadded = replicate (difforzero h sh) "" ++ ls - xpadded = map (padleft sw) ypadded - --- | Convert a multi-line string to a rectangular string bottom-padded to the specified height. -padbottom :: Int -> String -> String -padbottom h s = intercalate "\n" xpadded - where - ls = lines s - sh = length ls - sw | null ls = 0 - | otherwise = maximum $ map length ls - ypadded = ls ++ replicate (difforzero h sh) "" - xpadded = map (padleft sw) ypadded - --- | Convert a multi-line string to a rectangular string left-padded to the specified width. -padleft :: Int -> String -> String -padleft w "" = concat $ replicate w " " -padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s - --- | Convert a multi-line string to a rectangular string right-padded to the specified width. -padright :: Int -> String -> String -padright w "" = concat $ replicate w " " -padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s - --- | Clip a multi-line string to the specified width and height from the top left. -cliptopleft :: Int -> Int -> String -> String -cliptopleft w h = intercalate "\n" . take h . map (take w) . lines - --- | Clip and pad a multi-line string to fill the specified width and height. -fitto :: Int -> Int -> String -> String -fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline - where - rows = map (fit w) $ lines s - fit w = take w . (++ repeat ' ') - blankline = replicate w ' ' - --- encoded platform strings - --- | A platform string is a string value from or for the operating system, --- such as a file path or command-line argument (or environment variable's --- name or value ?). On some platforms (such as unix) these are not real --- unicode strings but have some encoding such as UTF-8. This alias does --- no type enforcement but aids code clarity. -type PlatformString = String - --- | Convert a possibly encoded platform string to a real unicode string. --- We decode the UTF-8 encoding recommended for unix systems --- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html) --- and leave anything else unchanged. -fromPlatformString :: PlatformString -> String -fromPlatformString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s - --- | Convert a unicode string to a possibly encoded platform string. --- On unix we encode with the recommended UTF-8 --- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html) --- and elsewhere we leave it unchanged. -toPlatformString :: String -> PlatformString -toPlatformString = case os of - "unix" -> UTF8.encodeString - "linux" -> UTF8.encodeString - "darwin" -> UTF8.encodeString - _ -> id - --- | A version of error that's better at displaying unicode. -error' :: String -> a -error' = error . toPlatformString - --- | A version of userError that's better at displaying unicode. -userError' :: String -> IOError -userError' = userError . toPlatformString - --- math - -difforzero :: (Num a, Ord a) => a -> a -> a -difforzero a b = maximum [(a - b), 0] - --- regexps - -containsRegex :: String -> String -> Bool -containsRegex r s = case matchRegexPR ("(?i)"++r) s of - Just _ -> True - _ -> False - - --- lists - -splitAtElement :: Eq a => a -> [a] -> [[a]] -splitAtElement e l = - case dropWhile (e==) l of - [] -> [] - l' -> first : splitAtElement e rest - where - (first,rest) = break (e==) l' - --- trees - -root = rootLabel -subs = subForest -branches = subForest - --- | List just the leaf nodes of a tree -leaves :: Tree a -> [a] -leaves (Node v []) = [v] -leaves (Node _ branches) = concatMap leaves branches - --- | get the sub-tree rooted at the first (left-most, depth-first) occurrence --- of the specified node value -subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a) -subtreeat v t - | root t == v = Just t - | otherwise = subtreeinforest v $ subs t - --- | get the sub-tree for the specified node value in the first tree in --- forest in which it occurs. -subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a) -subtreeinforest _ [] = Nothing -subtreeinforest v (t:ts) = case (subtreeat v t) of - Just t' -> Just t' - Nothing -> subtreeinforest v ts - --- | remove all nodes past a certain depth -treeprune :: Int -> Tree a -> Tree a -treeprune 0 t = Node (root t) [] -treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t) - --- | apply f to all tree nodes -treemap :: (a -> b) -> Tree a -> Tree b -treemap f t = Node (f $ root t) (map (treemap f) $ branches t) - --- | remove all subtrees whose nodes do not fulfill predicate -treefilter :: (a -> Bool) -> Tree a -> Tree a -treefilter f t = Node - (root t) - (map (treefilter f) $ filter (treeany f) $ branches t) - --- | is predicate true in any node of tree ? -treeany :: (a -> Bool) -> Tree a -> Bool -treeany f t = f (root t) || any (treeany f) (branches t) - --- treedrop -- remove the leaves which do fulfill predicate. --- treedropall -- do this repeatedly. - --- | show a compact ascii representation of a tree -showtree :: Show a => Tree a -> String -showtree = unlines . filter (containsRegex "[^ \\|]") . lines . drawTree . treemap show - --- | show a compact ascii representation of a forest -showforest :: Show a => Forest a -> String -showforest = concatMap showtree - --- debugging - --- | trace (print on stdout at runtime) a showable expression --- (for easily tracing in the middle of a complex expression) -strace :: Show a => a -> a -strace a = trace (show a) a - --- | labelled trace - like strace, with a label prepended -ltrace :: Show a => String -> a -> a -ltrace l a = trace (l ++ ": " ++ show a) a - --- | monadic trace - like strace, but works as a standalone line in a monad -mtrace :: (Monad m, Show a) => a -> m a -mtrace a = strace a `seq` return a - --- | trace an expression using a custom show function -tracewith f e = trace (f e) e - --- parsing - -choice' :: [GenParser tok st a] -> GenParser tok st a -choice' = choice . map Text.ParserCombinators.Parsec.try - -parsewith :: Parser a -> String -> Either ParseError a -parsewith p = parse p "" - -parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a -parseWithCtx ctx p = runParser p ctx "" - -fromparse :: Either ParseError a -> a -fromparse = either parseerror id - -parseerror e = error' $ showParseError e - -showParseError e = "parse error at " ++ show e - -showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e) - -nonspace :: GenParser Char st Char -nonspace = satisfy (not . isSpace) - -spacenonewline :: GenParser Char st Char -spacenonewline = satisfy (`elem` " \v\f\t") - -restofline :: GenParser Char st String -restofline = anyChar `manyTill` newline - --- time - -getCurrentLocalTime :: IO LocalTime -getCurrentLocalTime = do - t <- getCurrentTime - tz <- getCurrentTimeZone - return $ utcToLocalTime tz t - --- testing - --- | Get a Test's label, or the empty string. -tname :: Test -> String -tname (TestLabel n _) = n -tname _ = "" - --- | Flatten a Test containing TestLists into a list of single tests. -tflatten :: Test -> [Test] -tflatten (TestLabel _ t@(TestList _)) = tflatten t -tflatten (TestList ts) = concatMap tflatten ts -tflatten t = [t] - --- | Filter TestLists in a Test, recursively, preserving the structure. -tfilter :: (Test -> Bool) -> Test -> Test -tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts) -tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts -tfilter _ t = t - --- | Simple way to assert something is some expected value, with no label. -is :: (Eq a, Show a) => a -> a -> Assertion -a `is` e = assertEqual "" e a - --- | Assert a parse result is successful, printing the parse error on failure. -assertParse :: (Either ParseError a) -> Assertion -assertParse parse = either (assertFailure.show) (const (return ())) parse - --- | Assert a parse result is some expected value, printing the parse error on failure. -assertParseEqual :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion -assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse - -printParseError :: (Show a) => a -> IO () -printParseError e = do putStr "parse error at "; print e - - --- misc - -isLeft :: Either a b -> Bool -isLeft (Left _) = True -isLeft _ = False - -isRight :: Either a b -> Bool -isRight = not . isLeft - --- -- | Expand ~ in a file path (does not handle ~name). --- tildeExpand :: FilePath -> IO FilePath --- tildeExpand ('~':[]) = getHomeDirectory --- tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs)) --- --handle ~name, requires -fvia-C or ghc 6.8: --- --import System.Posix.User --- -- tildeExpand ('~':xs) = do let (user, path) = span (/= '/') xs --- -- pw <- getUserEntryForName user --- -- return (homeDirectory pw ++ path) --- tildeExpand xs = return xs - --- | Apply a function the specified number of times. Possibly uses O(n) stack ? -applyN :: Int -> (a -> a) -> a -> a -applyN n f = (!! n) . iterate f diff --git a/Hledger/Read.hs b/Hledger/Read.hs --- a/Hledger/Read.hs +++ b/Hledger/Read.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-| Read hledger data from various data formats, and related utilities. @@ -10,28 +9,35 @@ readJournalFile, readJournal, journalFromPathAndString, + ledgeraccountname, myJournalPath, myTimelogPath, myJournal, myTimelog, + someamount, + journalenvvar, + journaldefaultfilename ) where import Control.Monad.Error import Data.Either (partitionEithers) +import Data.List import Safe (headDef) import System.Directory (doesFileExist, getHomeDirectory) import System.Environment (getEnv) import System.FilePath (()) import System.IO (IOMode(..), withFile, stderr) +import Test.HUnit +import Text.Printf import Hledger.Data.Dates (getCurrentDay) import Hledger.Data.Types (Journal(..), Reader(..)) import Hledger.Data.Journal (nullctx) -import Hledger.Data.Utils -import Prelude hiding (getContents) -import Hledger.Data.UTF8 (getContents, hGetContents) import Hledger.Read.JournalReader as JournalReader import Hledger.Read.TimelogReader as TimelogReader +import Hledger.Utils +import Prelude hiding (getContents) +import Hledger.Utils.UTF8 (getContents, hGetContents) journalenvvar = "LEDGER_FILE" 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,3 @@ -{-# LANGUAGE CPP #-} {-| A reader for hledger's (and c++ ledger's) journal file format. @@ -110,22 +109,34 @@ ledgeraccountname, ledgerdatetime, ledgerDefaultYear, - ledgerExclamationDirective, + ledgerDirective, ledgerHistoricalPrice, reader, someamount, tests_Hledger_Read_JournalReader ) where -import Control.Monad.Error (ErrorT(..), throwError, catchError) +import Control.Monad +import Control.Monad.Error +import Data.Char (isNumber) +import Data.List import Data.List.Split (wordsBy) +import Data.Maybe +import Data.Time.Calendar +-- import Data.Time.Clock +-- import Data.Time.Format +import Data.Time.LocalTime import Safe (headDef) +-- import System.Locale (defaultTimeLocale) +import Test.HUnit import Text.ParserCombinators.Parsec hiding (parse) +import Text.Printf import Hledger.Data -import Prelude hiding (readFile) -import Hledger.Data.UTF8 (readFile) import Hledger.Read.Utils +import Hledger.Utils +import Prelude hiding (readFile) +import Hledger.Utils.UTF8 (readFile) -- let's get to it @@ -158,22 +169,13 @@ -- As all journal line types can be distinguished by the first -- character, excepting transactions versus empty (blank or -- comment-only) lines, can use choice w/o try - journalItem = choice [ ledgerExclamationDirective - , liftM (return . addTransaction) ledgerTransaction - , liftM (return . addModifierTransaction) ledgerModifierTransaction - , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction - , liftM (return . addHistoricalPrice) ledgerHistoricalPrice - , ledgerDefaultYear - , ledgerDefaultCommodity - , ledgerCommodityConversion - , ledgerIgnoredPriceCommodity - , ledgerTagDirective - , ledgerEndTagDirective - , emptyLine >> return (return id) - ] "journal transaction or directive" - -journalAddFile :: (FilePath,String) -> Journal -> Journal -journalAddFile f j@Journal{files=fs} = j{files=fs++[f]} + journalItem = choice [ ledgerDirective + , liftM (return . addTransaction) ledgerTransaction + , liftM (return . addModifierTransaction) ledgerModifierTransaction + , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction + , liftM (return . addHistoricalPrice) ledgerHistoricalPrice + , emptyLine >> return (return id) + ] "journal transaction or directive" emptyLine :: GenParser Char JournalContext () emptyLine = do many spacenonewline @@ -197,18 +199,27 @@ return s "comment" -ledgerExclamationDirective :: GenParser Char JournalContext JournalUpdate -ledgerExclamationDirective = do - char '!' "directive" - directive <- many nonspace - case directive of - "include" -> ledgerInclude - "account" -> ledgerAccountBegin - "end" -> ledgerAccountEnd - _ -> mzero +ledgerDirective :: GenParser Char JournalContext JournalUpdate +ledgerDirective = do + optional $ char '!' + choice' [ + ledgerInclude + ,ledgerAlias + ,ledgerEndAliases + ,ledgerAccountBegin + ,ledgerAccountEnd + ,ledgerTagDirective + ,ledgerEndTagDirective + ,ledgerDefaultYear + ,ledgerDefaultCommodity + ,ledgerCommodityConversion + ,ledgerIgnoredPriceCommodity + ] + "directive" ledgerInclude :: GenParser Char JournalContext JournalUpdate ledgerInclude = do + string "include" many1 spacenonewline filename <- restofline outerState <- getState @@ -223,64 +234,41 @@ ErrorT $ liftM Right (readFile fp) `catch` \err -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show err) -ledgerAccountBegin :: GenParser Char JournalContext JournalUpdate -ledgerAccountBegin = do many1 spacenonewline - parent <- ledgeraccountname - newline - pushParentAccount parent - return $ return id - -ledgerAccountEnd :: GenParser Char JournalContext JournalUpdate -ledgerAccountEnd = popParentAccount >> return (return id) - -ledgerModifierTransaction :: GenParser Char JournalContext ModifierTransaction -ledgerModifierTransaction = do - char '=' "modifier transaction" - many spacenonewline - valueexpr <- restofline - postings <- ledgerpostings - return $ ModifierTransaction valueexpr postings - -ledgerPeriodicTransaction :: GenParser Char JournalContext PeriodicTransaction -ledgerPeriodicTransaction = do - char '~' "periodic transaction" - many spacenonewline - periodexpr <- restofline - postings <- ledgerpostings - return $ PeriodicTransaction periodexpr postings - -ledgerHistoricalPrice :: GenParser Char JournalContext HistoricalPrice -ledgerHistoricalPrice = do - char 'P' "historical price" - many spacenonewline - date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate -- a time is ignored - many1 spacenonewline - symbol <- commoditysymbol - many spacenonewline - price <- someamount - restofline - return $ HistoricalPrice date symbol price +journalAddFile :: (FilePath,String) -> Journal -> Journal +journalAddFile f j@Journal{files=fs} = j{files=fs++[f]} -ledgerIgnoredPriceCommodity :: GenParser Char JournalContext JournalUpdate -ledgerIgnoredPriceCommodity = do - char 'N' "ignored-price commodity" +ledgerAccountBegin :: GenParser Char JournalContext JournalUpdate +ledgerAccountBegin = do + string "account" many1 spacenonewline - commoditysymbol - restofline + parent <- ledgeraccountname + newline + pushParentAccount parent return $ return id -ledgerCommodityConversion :: GenParser Char JournalContext JournalUpdate -ledgerCommodityConversion = do - char 'C' "commodity conversion" +ledgerAccountEnd :: GenParser Char JournalContext JournalUpdate +ledgerAccountEnd = do + string "end" + popParentAccount + return (return id) + +ledgerAlias :: GenParser Char JournalContext JournalUpdate +ledgerAlias = do + string "alias" many1 spacenonewline - someamount - many spacenonewline + orig <- many1 $ noneOf "=" char '=' - many spacenonewline - someamount - restofline + alias <- restofline + addAccountAlias (accountNameWithoutPostingType $ strip orig + ,accountNameWithoutPostingType $ strip alias) return $ return id +ledgerEndAliases :: GenParser Char JournalContext JournalUpdate +ledgerEndAliases = do + string "end aliases" + clearAccountAliases + return (return id) + ledgerTagDirective :: GenParser Char JournalContext JournalUpdate ledgerTagDirective = do string "tag" "tag directive" @@ -291,11 +279,10 @@ ledgerEndTagDirective :: GenParser Char JournalContext JournalUpdate ledgerEndTagDirective = do - string "end tag" "end tag directive" + (string "end tag" <|> string "pop") "end tag or pop directive" restofline return $ return id --- like ledgerAccountBegin, updates the JournalContext ledgerDefaultYear :: GenParser Char JournalContext JournalUpdate ledgerDefaultYear = do char 'Y' "default year" @@ -317,6 +304,54 @@ restofline return $ return id +ledgerHistoricalPrice :: GenParser Char JournalContext HistoricalPrice +ledgerHistoricalPrice = do + char 'P' "historical price" + many spacenonewline + date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate -- a time is ignored + many1 spacenonewline + symbol <- commoditysymbol + many spacenonewline + price <- someamount + restofline + return $ HistoricalPrice date symbol price + +ledgerIgnoredPriceCommodity :: GenParser Char JournalContext JournalUpdate +ledgerIgnoredPriceCommodity = do + char 'N' "ignored-price commodity" + many1 spacenonewline + commoditysymbol + restofline + return $ return id + +ledgerCommodityConversion :: GenParser Char JournalContext JournalUpdate +ledgerCommodityConversion = do + char 'C' "commodity conversion" + many1 spacenonewline + someamount + many spacenonewline + char '=' + many spacenonewline + someamount + restofline + return $ return id + +ledgerModifierTransaction :: GenParser Char JournalContext ModifierTransaction +ledgerModifierTransaction = do + char '=' "modifier transaction" + many spacenonewline + valueexpr <- restofline + postings <- ledgerpostings + return $ ModifierTransaction valueexpr postings + +ledgerPeriodicTransaction :: GenParser Char JournalContext PeriodicTransaction +ledgerPeriodicTransaction = do + char '~' "periodic transaction" + many spacenonewline + periodexpr <- restofline + postings <- ledgerpostings + return $ PeriodicTransaction periodexpr postings + -- | Parse a (possibly unbalanced) ledger transaction. ledgerTransaction :: GenParser Char JournalContext Transaction ledgerTransaction = do @@ -332,6 +367,8 @@ postings <- ledgerpostings return $ txnTieKnot $ Transaction date edate status code description comment md postings "" +-- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed. The year +-- may be omitted if a default year has already been set. ledgerdate :: GenParser Char JournalContext Day ledgerdate = do -- hacky: try to ensure precise errors for invalid dates @@ -340,28 +377,48 @@ datestr <- many1 $ choice' [digit, datesepchar] let dateparts = wordsBy (`elem` datesepchars) datestr currentyear <- getYear - let [y,m,d] = case (dateparts,currentyear) of - ([m,d],Just y) -> [show y,m,d] - ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown" - _ -> dateparts - maybedate = fromGregorianValid (read y) (read m) (read d) + [y,m,d] <- case (dateparts,currentyear) of + ([m,d],Just y) -> return [show y,m,d] + ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown" + ([y,m,d],_) -> return [y,m,d] + _ -> fail $ "bad date: " ++ datestr + let maybedate = fromGregorianValid (read y) (read m) (read d) case maybedate of Nothing -> fail $ "bad date: " ++ datestr Just date -> return date "full or partial date" +-- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format. Any +-- timezone will be ignored; the time is treated as local time. Fewer +-- digits are allowed, except in the timezone. The year may be omitted if +-- a default year has already been set. ledgerdatetime :: GenParser Char JournalContext LocalTime ledgerdatetime = do day <- ledgerdate many1 spacenonewline h <- many1 digit + let h' = read h + guard $ h' >= 0 && h' <= 23 char ':' m <- many1 digit - s <- optionMaybe $ do - char ':' - many1 digit - let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s) - return $ LocalTime day tod + let m' = read m + guard $ m' >= 0 && m' <= 59 + s <- optionMaybe $ char ':' >> many1 digit + let s' = case s of Just sstr -> read sstr + Nothing -> 0 + guard $ s' >= 0 && s' <= 59 + {- tz <- -} + optionMaybe $ do + plusminus <- oneOf "-+" + d1 <- digit + d2 <- digit + d3 <- digit + d4 <- digit + return $ plusminus:d1:d2:d3:d4:"" + -- ltz <- liftIO $ getCurrentTimeZone + -- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz + -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') + return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') ledgereffectivedate :: Day -> GenParser Char JournalContext Day ledgereffectivedate actualdate = do @@ -433,8 +490,8 @@ many1 spacenonewline status <- ledgerstatus many spacenonewline - account <- transactionaccountname - let (ptype, account') = (postingTypeFromAccountName account, unbracket account) + account <- modifiedaccountname + let (ptype, account') = (accountNamePostingType account, unbracket account) amount <- postingamount many spacenonewline comment <- ledgercomment <|> return "" @@ -442,9 +499,14 @@ md <- ledgermetadata return (Posting status account' amount comment ptype md Nothing) --- qualify with the parent account from parsing context -transactionaccountname :: GenParser Char JournalContext AccountName -transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname +-- Parse an account name, then apply any parent account prefix and/or account aliases currently in effect. +modifiedaccountname :: GenParser Char JournalContext AccountName +modifiedaccountname = do + a <- ledgeraccountname + prefix <- getParentAccount + let prefixed = prefix `joinAccountNames` a + aliases <- getAccountAliases + return $ accountNameApplyAliases aliases prefixed -- | Parse an account name. Account names may have single spaces inside -- them, and are terminated by two or more spaces. They should have one or @@ -668,16 +730,37 @@ ,"ledgerPeriodicTransaction" ~: do assertParse (parseWithCtx nullctx ledgerPeriodicTransaction "~ (some period expr)\n some:postings 1\n") - ,"ledgerExclamationDirective" ~: do - assertParse (parseWithCtx nullctx ledgerExclamationDirective "!include /some/file.x\n") - assertParse (parseWithCtx nullctx ledgerExclamationDirective "!account some:account\n") - assertParse (parseWithCtx nullctx (ledgerExclamationDirective >> ledgerExclamationDirective) "!account a\n!end\n") + ,"ledgerDirective" ~: do + assertParse (parseWithCtx nullctx ledgerDirective "!include /some/file.x\n") + assertParse (parseWithCtx nullctx ledgerDirective "account some:account\n") + assertParse (parseWithCtx nullctx (ledgerDirective >> ledgerDirective) "!account a\nend\n") ,"ledgercommentline" ~: do assertParse (parseWithCtx nullctx ledgercommentline "; some comment \n") assertParse (parseWithCtx nullctx ledgercommentline " \t; x\n") assertParse (parseWithCtx nullctx ledgercommentline ";x") + ,"ledgerdate" ~: do + assertParse (parseWithCtx nullctx ledgerdate "2011/1/1") + assertParseFailure (parseWithCtx nullctx ledgerdate "1/1") + assertParse (parseWithCtx nullctx{ctxYear=Just 2011} ledgerdate "1/1") + + ,"ledgerdatetime" ~: do + let p = do {t <- ledgerdatetime; eof; return t} + bad = assertParseFailure . parseWithCtx nullctx p + good = assertParse . parseWithCtx nullctx p + bad "2011/1/1" + bad "2011/1/1 24:00:00" + bad "2011/1/1 00:60:00" + bad "2011/1/1 00:00:60" + good "2011/1/1 00:00" + good "2011/1/1 23:59:59" + good "2011/1/1 3:5:7" + -- timezone is parsed but ignored + let startofday = LocalTime (fromGregorian 2011 1 1) (TimeOfDay 0 0 (fromIntegral 0)) + assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00-0800") startofday + assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00+1234") startofday + ,"ledgerDefaultYear" ~: do assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 2010\n") assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 10001\n") @@ -699,6 +782,8 @@ ,"ledgerEndTagDirective" ~: do assertParse (parseWithCtx nullctx ledgerEndTagDirective "end tag \n") + ,"ledgerEndTagDirective" ~: do + assertParse (parseWithCtx nullctx ledgerEndTagDirective "pop \n") ,"ledgeraccountname" ~: do assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c") diff --git a/Hledger/Read/TimelogReader.hs b/Hledger/Read/TimelogReader.hs --- a/Hledger/Read/TimelogReader.hs +++ b/Hledger/Read/TimelogReader.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-| A reader for the timelog file format generated by timeclock.el. @@ -47,12 +46,16 @@ tests_Hledger_Read_TimelogReader ) where -import Control.Monad.Error (ErrorT(..)) +import Control.Monad +import Control.Monad.Error +import Test.HUnit import Text.ParserCombinators.Parsec hiding (parse) + import Hledger.Data import Hledger.Read.Utils -import Hledger.Read.JournalReader (ledgerExclamationDirective, ledgerHistoricalPrice, +import Hledger.Read.JournalReader (ledgerDirective, ledgerHistoricalPrice, ledgerDefaultYear, emptyLine, ledgerdatetime) +import Hledger.Utils reader :: Reader @@ -80,7 +83,7 @@ -- As all ledger line types can be distinguished by the first -- character, excepting transactions versus empty (blank or -- comment-only) lines, can use choice w/o try - timelogItem = choice [ ledgerExclamationDirective + timelogItem = choice [ ledgerDirective , liftM (return . addHistoricalPrice) ledgerHistoricalPrice , ledgerDefaultYear , emptyLine >> return (return id) diff --git a/Hledger/Read/Utils.hs b/Hledger/Read/Utils.hs --- a/Hledger/Read/Utils.hs +++ b/Hledger/Read/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} {-| Utilities common to hledger journal readers. -} @@ -6,15 +7,17 @@ where import Control.Monad.Error +import Data.List import System.Directory (getHomeDirectory) import System.FilePath(takeDirectory,combine) import System.Time (getClockTime) import Text.ParserCombinators.Parsec -import Hledger.Data.Types (Journal, JournalContext(..), Commodity, JournalUpdate) -import Hledger.Data.Utils +import Hledger.Data.Types +import Hledger.Utils +import Hledger.Data.Posting import Hledger.Data.Dates (getCurrentYear) -import Hledger.Data.Journal (nullctx, nulljournal, journalFinalise) +import Hledger.Data.Journal juSequence :: [JournalUpdate] -> JournalUpdate @@ -49,8 +52,7 @@ pushParentAccount :: String -> GenParser tok JournalContext () pushParentAccount parent = updateState addParentAccount - where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 } - normalize = (++ ":") + where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 } popParentAccount :: GenParser tok JournalContext () popParentAccount = do ctx0 <- getState @@ -59,7 +61,16 @@ (_:rest) -> setState $ ctx0 { ctxAccount = rest } getParentAccount :: GenParser tok JournalContext String -getParentAccount = liftM (concat . reverse . ctxAccount) getState +getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState + +addAccountAlias :: (AccountName,AccountName) -> GenParser tok JournalContext () +addAccountAlias a = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases}) + +getAccountAliases :: GenParser tok JournalContext [(AccountName,AccountName)] +getAccountAliases = liftM ctxAliases getState + +clearAccountAliases :: GenParser tok JournalContext () +clearAccountAliases = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]}) -- | Convert a possibly relative, possibly tilde-containing file path to an absolute one. -- using the current directory from a parsec source position. ~username is not supported. diff --git a/Hledger/Reports.hs b/Hledger/Reports.hs new file mode 100644 --- /dev/null +++ b/Hledger/Reports.hs @@ -0,0 +1,595 @@ +{-# LANGUAGE RecordWildCards #-} +{-| + +Generate several common kinds of report from a journal, as \"*Report\" - +simple intermediate data structures intended to be easily rendered as +text, html, json, csv etc. by hledger commands, hamlet templates, +javascript, or whatever. This is under Hledger.Cli since it depends +on the command-line options, should move to hledger-lib later. + +-} + +module Hledger.Reports ( + ReportOpts(..), + DisplayExp, + FormatStr, + defreportopts, + dateSpanFromOpts, + intervalFromOpts, + clearedValueFromOpts, + whichDateFromOpts, + journalSelectingDateFromOpts, + journalSelectingAmountFromOpts, + optsToFilterSpec, + -- * Entries report + EntriesReport, + EntriesReportItem, + entriesReport, + -- * Postings report + PostingsReport, + PostingsReportItem, + postingsReport, + mkpostingsReportItem, -- XXX for showPostingWithBalanceForVty in Hledger.Cli.Register + -- * Transactions report + TransactionsReport, + TransactionsReportItem, + triDate, + triBalance, + journalTransactionsReport, + accountTransactionsReport, + -- * Accounts report + AccountsReport, + AccountsReportItem, + accountsReport, + accountsReport2, + isInteresting, + -- * Tests + tests_Hledger_Reports +) +where + +import Control.Monad +import Data.List +import Data.Maybe +import Data.Ord +import Data.Time.Calendar +import Data.Tree +import Safe (headMay, lastMay) +import System.Console.CmdArgs -- for defaults support +import Test.HUnit +import Text.ParserCombinators.Parsec +import Text.Printf + +import Hledger.Data +import Hledger.Utils + +-- report options, used in hledger-lib and above +data ReportOpts = ReportOpts { + begin_ :: Maybe Day + ,end_ :: Maybe Day + ,period_ :: Maybe (Interval,DateSpan) + ,cleared_ :: Bool + ,uncleared_ :: Bool + ,cost_ :: Bool + ,depth_ :: Maybe Int + ,display_ :: Maybe DisplayExp + ,effective_ :: Bool + ,empty_ :: Bool + ,no_elide_ :: Bool + ,real_ :: Bool + ,flat_ :: Bool -- balance + ,drop_ :: Int -- balance + ,no_total_ :: Bool -- balance + ,daily_ :: Bool + ,weekly_ :: Bool + ,monthly_ :: Bool + ,quarterly_ :: Bool + ,yearly_ :: Bool + ,format_ :: Maybe FormatStr + ,patterns_ :: [String] + } deriving (Show) + +type DisplayExp = String +type FormatStr = String + +defreportopts = ReportOpts + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + +instance Default ReportOpts where def = defreportopts + +-- | Figure out the date span we should report on, based on any +-- begin/end/period options provided. A period option will cause begin and +-- end options to be ignored. +dateSpanFromOpts :: Day -> ReportOpts -> DateSpan +dateSpanFromOpts _ ReportOpts{..} = + case period_ of Just (_,span) -> span + Nothing -> DateSpan begin_ end_ + +-- | Figure out the reporting interval, if any, specified by the options. +-- --period overrides --daily overrides --weekly overrides --monthly etc. +intervalFromOpts :: ReportOpts -> Interval +intervalFromOpts ReportOpts{..} = + case period_ of + Just (interval,_) -> interval + Nothing -> i + where i | daily_ = Days 1 + | weekly_ = Weeks 1 + | monthly_ = Months 1 + | quarterly_ = Quarters 1 + | yearly_ = Years 1 + | otherwise = NoInterval + +-- | Get a maybe boolean representing the last cleared/uncleared option if any. +clearedValueFromOpts :: ReportOpts -> Maybe Bool +clearedValueFromOpts ReportOpts{..} | cleared_ = Just True + | uncleared_ = Just False + | otherwise = Nothing + +-- | Detect which date we will report on, based on --effective. +whichDateFromOpts :: ReportOpts -> WhichDate +whichDateFromOpts ReportOpts{..} = if effective_ then EffectiveDate else ActualDate + +-- | Convert this journal's transactions' primary date to either the +-- actual or effective date, as per options. +journalSelectingDateFromOpts :: ReportOpts -> Journal -> Journal +journalSelectingDateFromOpts opts = journalSelectingDate (whichDateFromOpts opts) + +-- | Convert this journal's postings' amounts to the cost basis amounts if +-- specified by options. +journalSelectingAmountFromOpts :: ReportOpts -> Journal -> Journal +journalSelectingAmountFromOpts opts + | cost_ opts = journalConvertAmountsToCost + | otherwise = id + +-- | Convert application options to the library's generic filter specification. +optsToFilterSpec :: ReportOpts -> Day -> FilterSpec +optsToFilterSpec opts@ReportOpts{..} d = FilterSpec { + datespan=dateSpanFromOpts d opts + ,cleared= clearedValueFromOpts opts + ,real=real_ + ,empty=empty_ + ,acctpats=apats + ,descpats=dpats + ,depth = depth_ + } + where (apats,dpats) = parsePatternArgs patterns_ + +-- | Gather filter pattern arguments into a list of account patterns and a +-- list of description patterns. We interpret pattern arguments as +-- follows: those prefixed with "desc:" are description patterns, all +-- others are account patterns; also patterns prefixed with "not:" are +-- negated. not: should come after desc: if both are used. +parsePatternArgs :: [String] -> ([String],[String]) +parsePatternArgs args = (as, ds') + where + descprefix = "desc:" + (ds, as) = partition (descprefix `isPrefixOf`) args + ds' = map (drop (length descprefix)) ds + +------------------------------------------------------------------------------- + +-- | A journal entries report is a list of whole transactions as +-- originally entered in the journal (mostly). Used by eg hledger's print +-- command and hledger-web's journal entries view. +type EntriesReport = [EntriesReportItem] +type EntriesReportItem = Transaction + +-- | Select transactions for an entries report. +entriesReport :: ReportOpts -> FilterSpec -> Journal -> EntriesReport +entriesReport opts fspec j = sortBy (comparing tdate) $ jtxns $ filterJournalTransactions fspec j' + where + j' = journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j + +------------------------------------------------------------------------------- + +-- | A postings report is a list of postings with a running total, a label +-- for the total field, and a little extra transaction info to help with rendering. +type PostingsReport = (String -- label for the running balance column XXX remove + ,[PostingsReportItem] -- line items, one per posting + ) +type PostingsReportItem = (Maybe (Day, String) -- transaction date and description if this is the first posting + ,Posting -- the posting + ,MixedAmount -- the running total after this posting + ) + +-- | Select postings from the journal and add running balance and other +-- information to make a postings report. Used by eg hledger's register command. +postingsReport :: ReportOpts -> FilterSpec -> Journal -> PostingsReport +postingsReport opts fspec j = (totallabel, postingsReportItems ps nullposting startbal (+)) + where + ps | interval == NoInterval = displayableps + | otherwise = summarisePostingsByInterval interval depth empty filterspan displayableps + (precedingps, displayableps, _) = postingsMatchingDisplayExpr (display_ opts) + $ depthClipPostings depth + $ journalPostings + $ filterJournalPostings fspec{depth=Nothing} + $ journalSelectingDateFromOpts opts + $ journalSelectingAmountFromOpts opts + j + startbal = sumPostings precedingps + filterspan = datespan fspec + (interval, depth, empty) = (intervalFromOpts opts, depth_ opts, empty_ opts) + +totallabel = "Total" +balancelabel = "Balance" + +-- | Generate postings report line items. +postingsReportItems :: [Posting] -> Posting -> MixedAmount -> (MixedAmount -> MixedAmount -> MixedAmount) -> [PostingsReportItem] +postingsReportItems [] _ _ _ = [] +postingsReportItems (p:ps) pprev b sumfn = i:(postingsReportItems ps p b' sumfn) + where + i = mkpostingsReportItem isfirst p b' + isfirst = ptransaction p /= ptransaction pprev + b' = b `sumfn` pamount p + +-- | Generate one postings report line item, from a flag indicating +-- whether to include transaction info, a posting, and the current running +-- balance. +mkpostingsReportItem :: Bool -> Posting -> MixedAmount -> PostingsReportItem +mkpostingsReportItem False p b = (Nothing, p, b) +mkpostingsReportItem True p b = (ds, p, b) + where ds = case ptransaction p of Just (Transaction{tdate=da,tdescription=de}) -> Just (da,de) + Nothing -> Just (nulldate,"") + +-- | Date-sort and split a list of postings into three spans - postings matched +-- by the given display expression, and the preceding and following postings. +postingsMatchingDisplayExpr :: Maybe String -> [Posting] -> ([Posting],[Posting],[Posting]) +postingsMatchingDisplayExpr d ps = (before, matched, after) + where + sorted = sortBy (comparing postingDate) ps + (before, rest) = break (displayExprMatches d) sorted + (matched, after) = span (displayExprMatches d) rest + +-- | Does this display expression allow this posting to be displayed ? +-- Raises an error if the display expression can't be parsed. +displayExprMatches :: Maybe String -> Posting -> Bool +displayExprMatches Nothing _ = True +displayExprMatches (Just d) p = (fromparse $ parsewith datedisplayexpr d) p + +-- | Parse a hledger display expression, which is a simple date test like +-- "d>[DATE]" or "d<=[DATE]", and return a "Posting"-matching predicate. +datedisplayexpr :: GenParser Char st (Posting -> Bool) +datedisplayexpr = do + char 'd' + op <- compareop + char '[' + (y,m,d) <- smartdate + char ']' + let date = parsedate $ printf "%04s/%02s/%02s" y m d + test op = return $ (`op` date) . postingDate + case op of + "<" -> test (<) + "<=" -> test (<=) + "=" -> test (==) + "==" -> test (==) + ">=" -> test (>=) + ">" -> test (>) + _ -> mzero + where + compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] + +-- | Clip the account names to the specified depth in a list of postings. +depthClipPostings :: Maybe Int -> [Posting] -> [Posting] +depthClipPostings depth = map (depthClipPosting depth) + +-- | Clip a posting's account name to the specified depth. +depthClipPosting :: Maybe Int -> Posting -> Posting +depthClipPosting Nothing p = p +depthClipPosting (Just d) p@Posting{paccount=a} = p{paccount=clipAccountName d a} + +-- XXX confusing, refactor + +-- | Convert a list of postings into summary postings. Summary postings +-- are one per account per interval and aggregated to the specified depth +-- if any. +summarisePostingsByInterval :: Interval -> Maybe Int -> Bool -> DateSpan -> [Posting] -> [Posting] +summarisePostingsByInterval interval depth empty filterspan ps = concatMap summarisespan $ splitSpan interval reportspan + where + summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s) + postingsinspan s = filter (isPostingInDateSpan s) ps + dataspan = postingsDateSpan ps + reportspan | empty = filterspan `orDatesFrom` dataspan + | otherwise = dataspan + +-- | Given a date span (representing a reporting interval) and a list of +-- postings within it: aggregate the postings so there is only one per +-- account, and adjust their date/description so that they will render +-- as a summary for this interval. +-- +-- As usual with date spans the end date is exclusive, but for display +-- purposes we show the previous day as end date, like ledger. +-- +-- When a depth argument is present, postings to accounts of greater +-- depth are aggregated where possible. +-- +-- The showempty flag includes spans with no postings and also postings +-- with 0 amount. +summarisePostingsInDateSpan :: DateSpan -> Maybe Int -> Bool -> [Posting] -> [Posting] +summarisePostingsInDateSpan (DateSpan b e) depth showempty ps + | null ps && (isNothing b || isNothing e) = [] + | null ps && showempty = [summaryp] + | otherwise = summaryps' + where + summaryp = summaryPosting b' ("- "++ showDate (addDays (-1) e')) + b' = fromMaybe (maybe nulldate postingDate $ headMay ps) b + e' = fromMaybe (maybe (addDays 1 nulldate) postingDate $ lastMay ps) e + summaryPosting date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}} + + summaryps' = (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps + summaryps = [summaryp{paccount=a,pamount=balancetoshowfor a} | a <- clippedanames] + anames = sort $ nub $ map paccount ps + -- aggregate balances by account, like journalToLedger, then do depth-clipping + (_,_,exclbalof,inclbalof) = groupPostings ps + clippedanames = nub $ map (clipAccountName d) anames + isclipped a = accountNameLevel a >= d + d = fromMaybe 99999 $ depth + balancetoshowfor a = + (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a) + +------------------------------------------------------------------------------- + +-- | A transactions report includes a list of transactions +-- (posting-filtered and unfiltered variants), a running balance, and some +-- other information helpful for rendering a register view (a flag +-- indicating multiple other accounts and a display string describing +-- them) with or without a notion of current account(s). +type TransactionsReport = (String -- label for the balance column, eg "balance" or "total" + ,[TransactionsReportItem] -- line items, one per transaction + ) +type TransactionsReportItem = (Transaction -- the corresponding transaction + ,Transaction -- the transaction with postings to the current account(s) removed + ,Bool -- is this a split, ie more than one other account posting + ,String -- a display string describing the other account(s), if any + ,MixedAmount -- the amount posted to the current account(s) (or total amount posted) + ,MixedAmount -- the running balance for the current account(s) after this transaction + ) + +triDate (t,_,_,_,_,_) = tdate t +triBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0" + (Amount{quantity=q}):_ -> show q + +-- | Select transactions from the whole journal for a transactions report, +-- with no \"current\" account. The end result is similar to +-- "postingsReport" except it uses matchers and transaction-based report +-- items and the items are most recent first. Used by eg hledger-web's +-- journal view. +journalTransactionsReport :: ReportOpts -> Journal -> Matcher -> TransactionsReport +journalTransactionsReport _ Journal{jtxns=ts} m = (totallabel, items) + where + ts' = sortBy (comparing tdate) $ filter (not . null . tpostings) $ map (filterTransactionPostings m) ts + items = reverse $ accountTransactionsReportItems m Nothing nullmixedamt id ts' + -- XXX items' first element should be the full transaction with all postings + +------------------------------------------------------------------------------- + +-- | Select transactions within one or more \"current\" accounts, and make a +-- transactions report relative to those account(s). This means: +-- +-- 1. it shows transactions from the point of view of the current account(s). +-- The transaction amount is the amount posted to the current account(s). +-- The other accounts' names are provided. +-- +-- 2. With no transaction filtering in effect other than a start date, it +-- shows the accurate historical running balance for the current account(s). +-- Otherwise it shows a running total starting at 0. +-- +-- Currently, reporting intervals are not supported, and report items are +-- most recent first. Used by eg hledger-web's account register view. +-- +accountTransactionsReport :: ReportOpts -> Journal -> Matcher -> Matcher -> TransactionsReport +accountTransactionsReport opts j m thisacctmatcher = (label, items) + where + -- transactions affecting this account, in date order + ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctmatcher) $ jtxns $ + journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j + -- starting balance: if we are filtering by a start date and nothing else, + -- the sum of postings to this account before that date; otherwise zero. + (startbal,label) | matcherIsNull m = (nullmixedamt, balancelabel) + | matcherIsStartDateOnly (effective_ opts) m = (sumPostings priorps, balancelabel) + | otherwise = (nullmixedamt, totallabel) + where + priorps = -- ltrace "priorps" $ + filter (matchesPosting + (-- ltrace "priormatcher" $ + MatchAnd [thisacctmatcher, tostartdatematcher])) + $ transactionsPostings ts + tostartdatematcher = MatchDate (DateSpan Nothing startdate) + startdate = matcherStartDate (effective_ opts) m + items = reverse $ accountTransactionsReportItems m (Just thisacctmatcher) startbal negate ts + +-- | Generate transactions report items from a list of transactions, +-- using the provided query and current account matchers, starting balance, +-- sign-setting function and balance-summing function. +accountTransactionsReportItems :: Matcher -> Maybe Matcher -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem] +accountTransactionsReportItems _ _ _ _ [] = [] +accountTransactionsReportItems matcher thisacctmatcher bal signfn (t:ts) = + -- This is used for both accountTransactionsReport and journalTransactionsReport, + -- which makes it a bit overcomplicated + case i of Just i' -> i':is + Nothing -> is + where + tmatched@Transaction{tpostings=psmatched} = filterTransactionPostings matcher t + (psthisacct,psotheracct) = case thisacctmatcher of Just m -> partition (matchesPosting m) psmatched + Nothing -> ([],psmatched) + numotheraccts = length $ nub $ map paccount psotheracct + amt = sum $ map pamount psotheracct + acct | isNothing thisacctmatcher = summarisePostings psmatched -- journal register + | numotheraccts == 0 = "transfer between " ++ summarisePostingAccounts psthisacct + | otherwise = prefix ++ summarisePostingAccounts psotheracct + where prefix = maybe "" (\b -> if b then "from " else "to ") $ isNegativeMixedAmount amt + (i,bal') = case psmatched of + [] -> (Nothing,bal) + _ -> (Just (t, tmatched, numotheraccts > 1, acct, a, b), b) + where + a = signfn amt + b = bal + a + is = accountTransactionsReportItems matcher thisacctmatcher bal' signfn ts + +-- | Generate a short readable summary of some postings, like +-- "from (negatives) to (positives)". +summarisePostings :: [Posting] -> String +summarisePostings ps = + case (summarisePostingAccounts froms, summarisePostingAccounts tos) of + ("",t) -> "to "++t + (f,"") -> "from "++f + (f,t) -> "from "++f++" to "++t + where + (froms,tos) = partition (fromMaybe False . isNegativeMixedAmount . pamount) ps + +-- | Generate a simplified summary of some postings' accounts. +summarisePostingAccounts :: [Posting] -> String +summarisePostingAccounts = intercalate ", " . map accountLeafName . nub . map paccount + +filterTransactionPostings :: Matcher -> Transaction -> Transaction +filterTransactionPostings m t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps} + +------------------------------------------------------------------------------- + +-- | An accounts report is a list of account names (full and short +-- variants) with their balances, appropriate indentation for rendering as +-- a hierarchy, and grand total. +type AccountsReport = ([AccountsReportItem] -- line items, one per account + ,MixedAmount -- total balance of all accounts + ) +type AccountsReportItem = (AccountName -- full account name + ,AccountName -- short account name for display (the leaf name, prefixed by any boring parents immediately above) + ,Int -- how many steps to indent this account (0-based account depth excluding boring parents) + ,MixedAmount) -- account balance, includes subs unless --flat is present + +-- | Select accounts, and get their balances at the end of the selected +-- period, and misc. display information, for an accounts report. Used by +-- eg hledger's balance command. +accountsReport :: ReportOpts -> FilterSpec -> Journal -> AccountsReport +accountsReport opts filterspec j = accountsReport' opts j (journalToLedger filterspec) + +-- | Select accounts, and get their balances at the end of the selected +-- period, and misc. display information, for an accounts report. Like +-- "accountsReport" but uses the new matchers. Used by eg hledger-web's +-- accounts sidebar. +accountsReport2 :: ReportOpts -> Matcher -> Journal -> AccountsReport +accountsReport2 opts matcher j = accountsReport' opts j (journalToLedger2 matcher) + +-- Accounts report helper. +accountsReport' :: ReportOpts -> Journal -> (Journal -> Ledger) -> AccountsReport +accountsReport' opts j jtol = (items, total) + where + items = map mkitem interestingaccts + interestingaccts | no_elide_ opts = acctnames + | otherwise = filter (isInteresting opts l) acctnames + acctnames = sort $ tail $ flatten $ treemap aname accttree + accttree = ledgerAccountTree (fromMaybe 99999 $ depth_ opts) l + total = sum $ map abalance $ ledgerTopAccounts l + l = jtol $ journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j + + -- | Get data for one balance report line item. + mkitem :: AccountName -> AccountsReportItem + mkitem a = (a, adisplay, indent, abal) + where + adisplay | flat_ opts = a + | otherwise = accountNameFromComponents $ reverse (map accountLeafName ps) ++ [accountLeafName a] + where ps = takeWhile boring parents where boring = not . (`elem` interestingparents) + indent | flat_ opts = 0 + | otherwise = length interestingparents + interestingparents = filter (`elem` interestingaccts) parents + parents = parentAccountNames a + abal | flat_ opts = exclusiveBalance acct + | otherwise = abalance acct + where acct = ledgerAccount l a + +exclusiveBalance :: Account -> MixedAmount +exclusiveBalance = sumPostings . apostings + +-- | Is the named account considered interesting for this ledger's accounts report, +-- following the eliding style of ledger's balance command ? +isInteresting :: ReportOpts -> Ledger -> AccountName -> Bool +isInteresting opts l a | flat_ opts = isInterestingFlat opts l a + | otherwise = isInterestingIndented opts l a + +isInterestingFlat :: ReportOpts -> Ledger -> AccountName -> Bool +isInterestingFlat opts l a = notempty || emptyflag + where + acct = ledgerAccount l a + notempty = not $ isZeroMixedAmount $ exclusiveBalance acct + emptyflag = empty_ opts + +isInterestingIndented :: ReportOpts -> Ledger -> AccountName -> Bool +isInterestingIndented opts l a + | numinterestingsubs==1 && not atmaxdepth = notlikesub + | otherwise = notzero || emptyflag + where + atmaxdepth = isJust d && Just (accountNameLevel a) == d where d = depth_ opts + emptyflag = empty_ opts + acct = ledgerAccount l a + notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct + notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumPostings $ apostings acct + numinterestingsubs = length $ filter isInterestingTree subtrees + where + isInterestingTree = treeany (isInteresting opts l . aname) + subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a + +------------------------------------------------------------------------------- + +tests_Hledger_Reports :: Test +tests_Hledger_Reports = TestList + [ + + "summarisePostingsByInterval" ~: do + summarisePostingsByInterval (Quarters 1) Nothing False (DateSpan Nothing Nothing) [] ~?= [] + + -- ,"summarisePostingsInDateSpan" ~: do + -- let gives (b,e,depth,showempty,ps) = + -- (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`) + -- let ps = + -- [ + -- nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]} + -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 2]} + -- ,nullposting{lpdescription="desc",lpaccount="expenses:food", lpamount=Mixed [dollars 4]} + -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 8]} + -- ] + -- ("2008/01/01","2009/01/01",0,9999,False,[]) `gives` + -- [] + -- ("2008/01/01","2009/01/01",0,9999,True,[]) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31"} + -- ] + -- ("2008/01/01","2009/01/01",0,9999,False,ts) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food", lpamount=Mixed [dollars 4]} + -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 10]} + -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]} + -- ] + -- ("2008/01/01","2009/01/01",0,2,False,ts) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [dollars 15]} + -- ] + -- ("2008/01/01","2009/01/01",0,1,False,ts) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [dollars 15]} + -- ] + -- ("2008/01/01","2009/01/01",0,0,False,ts) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [dollars 15]} + -- ] + + ] diff --git a/Hledger/Utils.hs b/Hledger/Utils.hs new file mode 100644 --- /dev/null +++ b/Hledger/Utils.hs @@ -0,0 +1,427 @@ +{-| + +Standard imports and utilities which are useful everywhere, or needed low +in the module hierarchy. This is the bottom of hledger's module graph. + +-} + +module Hledger.Utils (---- provide these frequently used modules - or not, for clearer api: + -- module Control.Monad, + -- module Data.List, + -- module Data.Maybe, + -- module Data.Time.Calendar, + -- module Data.Time.Clock, + -- module Data.Time.LocalTime, + -- module Data.Tree, + -- module Debug.Trace, + -- module Text.RegexPR, + -- module Test.HUnit, + -- module Text.Printf, + ---- all of this one: + module Hledger.Utils, + Debug.Trace.trace + ---- and this for i18n - needs to be done in each module I think: + -- module Hledger.Utils.UTF8 + ) +where +import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded) +import Data.Char +import Data.List +import Data.Maybe +import Data.Time.Clock +import Data.Time.LocalTime +import Data.Tree +import Debug.Trace +import System.Info (os) +import Test.HUnit +import Text.ParserCombinators.Parsec +import Text.Printf +import Text.RegexPR +-- import qualified Data.Map as Map +-- +-- import Prelude hiding (readFile,writeFile,getContents,putStr,putStrLn) +-- import Hledger.Utils.UTF8 + +-- strings + +lowercase = map toLower +uppercase = map toUpper + +strip = lstrip . rstrip +lstrip = dropWhile (`elem` " \t") +rstrip = reverse . lstrip . reverse + +elideLeft width s = + if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s + +elideRight width s = + if length s > width then take (width - 2) s ++ ".." else s + +underline :: String -> String +underline s = s' ++ replicate (length s) '-' ++ "\n" + where s' + | last s == '\n' = s + | otherwise = s ++ "\n" + +-- | Wrap a string in single quotes, and \-prefix any embedded single +-- quotes, if it contains whitespace and is not already single- or +-- double-quoted. +quoteIfSpaced :: String -> String +quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s + | not $ any (`elem` s) whitespacechars = s + | otherwise = "'"++escapeSingleQuotes s++"'" + where escapeSingleQuotes = regexReplace "'" "\'" + +-- | Quote-aware version of words - don't split on spaces which are inside quotes. +-- NB correctly handles "a'b" but not "''a''". +words' :: String -> [String] +words' = map stripquotes . fromparse . parsewith p + where + p = do ss <- (quotedPattern <|> pattern) `sepBy` many1 spacenonewline + -- eof + return ss + pattern = many (noneOf whitespacechars) + quotedPattern = between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\"" + +-- | Quote-aware version of unwords - single-quote strings which contain whitespace +unwords' :: [String] -> String +unwords' = unwords . map singleQuoteIfNeeded + +singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'" + | otherwise = s + +whitespacechars = " \t\n\r" + +-- | Strip one matching pair of single or double quotes on the ends of a string. +stripquotes :: String -> String +stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s + +isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\'' +isSingleQuoted _ = False + +isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"' +isDoubleQuoted _ = False + +unbracket :: String -> String +unbracket s + | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s + | otherwise = s + +-- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded. +concatTopPadded :: [String] -> String +concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded + where + lss = map lines strs + h = maximum $ map length lss + ypad ls = replicate (difforzero h (length ls)) "" ++ ls + xpad ls = map (padleft w) ls where w | null ls = 0 + | otherwise = maximum $ map length ls + padded = map (xpad . ypad) lss + +-- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded. +concatBottomPadded :: [String] -> String +concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded + where + lss = map lines strs + h = maximum $ map length lss + ypad ls = ls ++ replicate (difforzero h (length ls)) "" + xpad ls = map (padleft w) ls where w | null ls = 0 + | otherwise = maximum $ map length ls + padded = map (xpad . ypad) lss + +-- | Compose strings vertically and right-aligned. +vConcatRightAligned :: [String] -> String +vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss + where + showfixedwidth = printf (printf "%%%ds" width) + width = maximum $ map length ss + +-- | Convert a multi-line string to a rectangular string top-padded to the specified height. +padtop :: Int -> String -> String +padtop h s = intercalate "\n" xpadded + where + ls = lines s + sh = length ls + sw | null ls = 0 + | otherwise = maximum $ map length ls + ypadded = replicate (difforzero h sh) "" ++ ls + xpadded = map (padleft sw) ypadded + +-- | Convert a multi-line string to a rectangular string bottom-padded to the specified height. +padbottom :: Int -> String -> String +padbottom h s = intercalate "\n" xpadded + where + ls = lines s + sh = length ls + sw | null ls = 0 + | otherwise = maximum $ map length ls + ypadded = ls ++ replicate (difforzero h sh) "" + xpadded = map (padleft sw) ypadded + +-- | Convert a multi-line string to a rectangular string left-padded to the specified width. +padleft :: Int -> String -> String +padleft w "" = concat $ replicate w " " +padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s + +-- | Convert a multi-line string to a rectangular string right-padded to the specified width. +padright :: Int -> String -> String +padright w "" = concat $ replicate w " " +padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s + +-- | Clip a multi-line string to the specified width and height from the top left. +cliptopleft :: Int -> Int -> String -> String +cliptopleft w h = intercalate "\n" . take h . map (take w) . lines + +-- | Clip and pad a multi-line string to fill the specified width and height. +fitto :: Int -> Int -> String -> String +fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline + where + rows = map (fit w) $ lines s + fit w = take w . (++ repeat ' ') + blankline = replicate w ' ' + +-- encoded platform strings + +-- | A platform string is a string value from or for the operating system, +-- such as a file path or command-line argument (or environment variable's +-- name or value ?). On some platforms (such as unix) these are not real +-- unicode strings but have some encoding such as UTF-8. This alias does +-- no type enforcement but aids code clarity. +type PlatformString = String + +-- | Convert a possibly encoded platform string to a real unicode string. +-- We decode the UTF-8 encoding recommended for unix systems +-- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html) +-- and leave anything else unchanged. +fromPlatformString :: PlatformString -> String +fromPlatformString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s + +-- | Convert a unicode string to a possibly encoded platform string. +-- On unix we encode with the recommended UTF-8 +-- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html) +-- and elsewhere we leave it unchanged. +toPlatformString :: String -> PlatformString +toPlatformString = case os of + "unix" -> UTF8.encodeString + "linux" -> UTF8.encodeString + "darwin" -> UTF8.encodeString + _ -> id + +-- | A version of error that's better at displaying unicode. +error' :: String -> a +error' = error . toPlatformString + +-- | A version of userError that's better at displaying unicode. +userError' :: String -> IOError +userError' = userError . toPlatformString + +-- math + +difforzero :: (Num a, Ord a) => a -> a -> a +difforzero a b = maximum [(a - b), 0] + +-- regexps + +-- regexMatch :: String -> String -> MatchFun Maybe +regexMatch r s = matchRegexPR r s + +-- regexMatchCI :: String -> String -> MatchFun Maybe +regexMatchCI r s = regexMatch (regexToCaseInsensitive r) s + +regexMatches :: String -> String -> Bool +regexMatches r s = isJust $ matchRegexPR r s + +regexMatchesCI :: String -> String -> Bool +regexMatchesCI r s = regexMatches (regexToCaseInsensitive r) s + +containsRegex = regexMatchesCI + +regexReplace :: String -> String -> String -> String +regexReplace r repl s = gsubRegexPR r repl s + +regexReplaceCI :: String -> String -> String -> String +regexReplaceCI r s = regexReplace (regexToCaseInsensitive r) s + +regexReplaceBy :: String -> (String -> String) -> String -> String +regexReplaceBy r replfn s = gsubRegexPRBy r replfn s + +regexToCaseInsensitive :: String -> String +regexToCaseInsensitive r = "(?i)"++ r + +-- lists + +splitAtElement :: Eq a => a -> [a] -> [[a]] +splitAtElement e l = + case dropWhile (e==) l of + [] -> [] + l' -> first : splitAtElement e rest + where + (first,rest) = break (e==) l' + +-- trees + +root = rootLabel +subs = subForest +branches = subForest + +-- | List just the leaf nodes of a tree +leaves :: Tree a -> [a] +leaves (Node v []) = [v] +leaves (Node _ branches) = concatMap leaves branches + +-- | get the sub-tree rooted at the first (left-most, depth-first) occurrence +-- of the specified node value +subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a) +subtreeat v t + | root t == v = Just t + | otherwise = subtreeinforest v $ subs t + +-- | get the sub-tree for the specified node value in the first tree in +-- forest in which it occurs. +subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a) +subtreeinforest _ [] = Nothing +subtreeinforest v (t:ts) = case (subtreeat v t) of + Just t' -> Just t' + Nothing -> subtreeinforest v ts + +-- | remove all nodes past a certain depth +treeprune :: Int -> Tree a -> Tree a +treeprune 0 t = Node (root t) [] +treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t) + +-- | apply f to all tree nodes +treemap :: (a -> b) -> Tree a -> Tree b +treemap f t = Node (f $ root t) (map (treemap f) $ branches t) + +-- | remove all subtrees whose nodes do not fulfill predicate +treefilter :: (a -> Bool) -> Tree a -> Tree a +treefilter f t = Node + (root t) + (map (treefilter f) $ filter (treeany f) $ branches t) + +-- | is predicate true in any node of tree ? +treeany :: (a -> Bool) -> Tree a -> Bool +treeany f t = f (root t) || any (treeany f) (branches t) + +-- treedrop -- remove the leaves which do fulfill predicate. +-- treedropall -- do this repeatedly. + +-- | show a compact ascii representation of a tree +showtree :: Show a => Tree a -> String +showtree = unlines . filter (regexMatches "[^ \\|]") . lines . drawTree . treemap show + +-- | show a compact ascii representation of a forest +showforest :: Show a => Forest a -> String +showforest = concatMap showtree + +-- debugging + +-- | trace (print on stdout at runtime) a showable expression +-- (for easily tracing in the middle of a complex expression) +strace :: Show a => a -> a +strace a = trace (show a) a + +-- | labelled trace - like strace, with a label prepended +ltrace :: Show a => String -> a -> a +ltrace l a = trace (l ++ ": " ++ show a) a + +-- | monadic trace - like strace, but works as a standalone line in a monad +mtrace :: (Monad m, Show a) => a -> m a +mtrace a = strace a `seq` return a + +-- | trace an expression using a custom show function +tracewith :: (a -> String) -> a -> a +tracewith f e = trace (f e) e + +-- parsing + +-- | Backtracking choice, use this when alternatives share a prefix. +-- Consumes no input if all choices fail. +choice' :: [GenParser tok st a] -> GenParser tok st a +choice' = choice . map Text.ParserCombinators.Parsec.try + +parsewith :: Parser a -> String -> Either ParseError a +parsewith p = parse p "" + +parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a +parseWithCtx ctx p = runParser p ctx "" + +fromparse :: Either ParseError a -> a +fromparse = either parseerror id + +parseerror :: ParseError -> a +parseerror e = error' $ showParseError e + +showParseError :: ParseError -> String +showParseError e = "parse error at " ++ show e + +showDateParseError :: ParseError -> String +showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e) + +nonspace :: GenParser Char st Char +nonspace = satisfy (not . isSpace) + +spacenonewline :: GenParser Char st Char +spacenonewline = satisfy (`elem` " \v\f\t") + +restofline :: GenParser Char st String +restofline = anyChar `manyTill` newline + +-- time + +getCurrentLocalTime :: IO LocalTime +getCurrentLocalTime = do + t <- getCurrentTime + tz <- getCurrentTimeZone + return $ utcToLocalTime tz t + +-- testing + +-- | Get a Test's label, or the empty string. +tname :: Test -> String +tname (TestLabel n _) = n +tname _ = "" + +-- | Flatten a Test containing TestLists into a list of single tests. +tflatten :: Test -> [Test] +tflatten (TestLabel _ t@(TestList _)) = tflatten t +tflatten (TestList ts) = concatMap tflatten ts +tflatten t = [t] + +-- | Filter TestLists in a Test, recursively, preserving the structure. +tfilter :: (Test -> Bool) -> Test -> Test +tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts) +tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts +tfilter _ t = t + +-- | Simple way to assert something is some expected value, with no label. +is :: (Eq a, Show a) => a -> a -> Assertion +a `is` e = assertEqual "" e a + +-- | Assert a parse result is successful, printing the parse error on failure. +assertParse :: (Either ParseError a) -> Assertion +assertParse parse = either (assertFailure.show) (const (return ())) parse + +-- | Assert a parse result is successful, printing the parse error on failure. +assertParseFailure :: (Either ParseError a) -> Assertion +assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse + +-- | Assert a parse result is some expected value, printing the parse error on failure. +assertParseEqual :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion +assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse + +printParseError :: (Show a) => a -> IO () +printParseError e = do putStr "parse error at "; print e + +-- misc + +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft _ = False + +isRight :: Either a b -> Bool +isRight = not . isLeft + +-- | Apply a function the specified number of times. Possibly uses O(n) stack ? +applyN :: Int -> (a -> a) -> a -> a +applyN n f = (!! n) . iterate f diff --git a/Hledger/Utils/UTF8.hs b/Hledger/Utils/UTF8.hs new file mode 100644 --- /dev/null +++ b/Hledger/Utils/UTF8.hs @@ -0,0 +1,87 @@ +{- +From pandoc, slightly extended. Example usage: + + import Prelude hiding (readFile,writeFile,getContents,putStr,putStrLn) + import Hledger.Utils.UTF8 (readFile,writeFile,getContents,putStr,putStrLn) + + +---------------------------------------------------------------------- +Copyright (C) 2010 John MacFarlane + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.UTF8 + Copyright : Copyright (C) 2010 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +UTF-8 aware string IO functions that will work with GHC 6.10 or 6.12. +-} +module Hledger.Utils.UTF8 ( readFile + , writeFile + , appendFile + , getContents + , hGetContents + , putStr + , putStrLn + , hPutStr + , hPutStrLn + ) + +where +import qualified Data.ByteString.Lazy as B +import Data.ByteString.Lazy.UTF8 (toString, fromString) +import Prelude hiding (readFile, writeFile, appendFile, getContents, putStr, putStrLn) +import System.IO (Handle) +import Control.Monad (liftM) + +bom :: B.ByteString +bom = B.pack [0xEF, 0xBB, 0xBF] + +stripBOM :: B.ByteString -> B.ByteString +stripBOM s | bom `B.isPrefixOf` s = B.drop 3 s +stripBOM s = s + +readFile :: FilePath -> IO String +readFile = liftM (toString . stripBOM) . B.readFile + +writeFile :: FilePath -> String -> IO () +writeFile f = B.writeFile f . fromString + +appendFile :: FilePath -> String -> IO () +appendFile f = B.appendFile f . fromString + +getContents :: IO String +getContents = liftM (toString . stripBOM) B.getContents + +hGetContents :: Handle -> IO String +hGetContents h = liftM (toString . stripBOM) (B.hGetContents h) + +putStr :: String -> IO () +putStr = B.putStr . fromString + +putStrLn :: String -> IO () +putStrLn = B.putStrLn . fromString + +hPutStr :: Handle -> String -> IO () +hPutStr h = B.hPutStr h . fromString + +hPutStrLn :: Handle -> String -> IO () +hPutStrLn h s = hPutStr h (s ++ "\n") diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,2 @@ -#!/usr/bin/env runhaskell import Distribution.Simple - main = defaultMain diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -1,11 +1,14 @@ name: hledger-lib -version: 0.14 +version: 0.15 category: Finance -synopsis: Reusable types and utilities for the hledger accounting tool and financial apps in general. +synopsis: Core data types, parsers and utilities for the hledger accounting tool. description: - hledger is a haskell port and friendly fork of John Wiegley's ledger accounting tool. - This package provides core data types, parsers and utilities used by the hledger tools. - It also aims to be a useful library for building h/ledger-compatible tools or unrelated financial apps in haskell. + hledger is a library and set of user tools for working + with financial data (or anything that can be tracked in a + double-entry accounting ledger.) It is a haskell port and + friendly fork of John Wiegley's Ledger. hledger provides + command-line, curses and web interfaces, and aims to be a + reliable, practical tool for daily use. license: GPL license-file: LICENSE @@ -14,7 +17,7 @@ homepage: http://hledger.org bug-reports: http://code.google.com/p/hledger/issues stability: beta -tested-with: GHC==6.10 +tested-with: GHC==6.12, GHC==7.0 cabal-version: >= 1.6 build-type: Simple -- data-dir: data @@ -29,6 +32,7 @@ -- should set patchlevel here as in Makefile cpp-options: -DPATCHLEVEL=0 exposed-modules: + Hledger Hledger.Data Hledger.Data.Account Hledger.Data.AccountName @@ -38,18 +42,21 @@ Hledger.Data.Transaction Hledger.Data.Journal Hledger.Data.Ledger + Hledger.Data.Matching Hledger.Data.Posting Hledger.Data.TimeLog Hledger.Data.Types - Hledger.Data.Utils - Hledger.Data.UTF8 Hledger.Read - Hledger.Read.Utils Hledger.Read.JournalReader Hledger.Read.TimelogReader + Hledger.Read.Utils + Hledger.Reports + Hledger.Utils + Hledger.Utils.UTF8 Build-Depends: base >= 3 && < 5 ,bytestring + ,cmdargs >= 0.8 && < 0.9 ,containers ,directory ,filepath