diff --git a/Hledger/Data.hs b/Hledger/Data.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data.hs @@ -0,0 +1,58 @@ +{-| + +The Ledger library allows parsing and querying of ledger files. It +generally provides a compatible subset of C++ ledger's functionality. +This package re-exports all the Ledger.* modules. + +-} + +module Hledger.Data ( + module Hledger.Data.Account, + module Hledger.Data.AccountName, + module Hledger.Data.Amount, + module Hledger.Data.Commodity, + module Hledger.Data.Dates, + module Hledger.Data.IO, + module Hledger.Data.Transaction, + module Hledger.Data.Ledger, + module Hledger.Data.Parse, + module Hledger.Data.Journal, + module Hledger.Data.Posting, + module Hledger.Data.TimeLog, + module Hledger.Data.Types, + module Hledger.Data.Utils, + tests_Hledger_Data + ) +where +import Hledger.Data.Account +import Hledger.Data.AccountName +import Hledger.Data.Amount +import Hledger.Data.Commodity +import Hledger.Data.Dates +import Hledger.Data.IO +import Hledger.Data.Transaction +import Hledger.Data.Ledger +import Hledger.Data.Parse +import Hledger.Data.Journal +import Hledger.Data.Posting +import Hledger.Data.TimeLog +import Hledger.Data.Types +import Hledger.Data.Utils + +tests_Hledger_Data = TestList + [ + -- Hledger.Data.Account.tests_Account + -- ,Hledger.Data.AccountName.tests_AccountName + Hledger.Data.Amount.tests_Amount + -- ,Hledger.Data.Commodity.tests_Commodity + ,Hledger.Data.Dates.tests_Dates + -- ,Hledger.Data.IO.tests_IO + ,Hledger.Data.Transaction.tests_Transaction + -- ,Hledger.Data.Hledger.Data.tests_Hledger.Data + ,Hledger.Data.Parse.tests_Parse + -- ,Hledger.Data.Journal.tests_Journal + -- ,Hledger.Data.Posting.tests_Posting + ,Hledger.Data.TimeLog.tests_TimeLog + -- ,Hledger.Data.Types.tests_Types + -- ,Hledger.Data.Utils.tests_Utils + ] diff --git a/Hledger/Data/Account.hs b/Hledger/Data/Account.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Account.hs @@ -0,0 +1,27 @@ +{-| + +A compound data type for efficiency. An 'Account' stores + +- an 'AccountName', + +- all 'Posting's in the account, excluding subaccounts + +- a 'MixedAmount' representing the account balance, including subaccounts. + +-} + +module Hledger.Data.Account +where +import Hledger.Data.Utils +import Hledger.Data.Types +import Hledger.Data.Amount + + +instance Show Account where + show (Account a ts b) = printf "Account %s with %d txns and %s balance" a (length ts) (showMixedAmount b) + +instance Eq Account where + (==) (Account n1 t1 b1) (Account n2 t2 b2) = n1 == n2 && t1 == t2 && b1 == b2 + +nullacct = Account "" [] nullmixedamt + diff --git a/Hledger/Data/AccountName.hs b/Hledger/Data/AccountName.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/AccountName.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE NoMonomorphismRestriction#-} +{-| + +'AccountName's are strings like @assets:cash:petty@. +From a set of these we derive the account hierarchy. + +-} + +module Hledger.Data.AccountName +where +import Hledger.Data.Utils +import Hledger.Data.Types +import Data.Map (Map) +import qualified Data.Map as M + + + +-- change to use a different separator for nested accounts +acctsepchar = ':' + +accountNameComponents :: AccountName -> [String] +accountNameComponents = splitAtElement acctsepchar + +accountNameFromComponents :: [String] -> AccountName +accountNameFromComponents = concat . intersperse [acctsepchar] + +accountLeafName :: AccountName -> String +accountLeafName = last . accountNameComponents + +accountNameLevel :: AccountName -> Int +accountNameLevel "" = 0 +accountNameLevel a = length (filter (==acctsepchar) a) + 1 + +-- | ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"] +expandAccountNames :: [AccountName] -> [AccountName] +expandAccountNames as = nub $ concatMap expand as + where expand = map accountNameFromComponents . tail . inits . accountNameComponents + +-- | ["a:b:c","d:e"] -> ["a","d"] +topAccountNames :: [AccountName] -> [AccountName] +topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1] + +parentAccountName :: AccountName -> AccountName +parentAccountName = accountNameFromComponents . init . accountNameComponents + +parentAccountNames :: AccountName -> [AccountName] +parentAccountNames a = parentAccountNames' $ parentAccountName a + where + parentAccountNames' "" = [] + parentAccountNames' a = a : parentAccountNames' (parentAccountName a) + +isAccountNamePrefixOf :: AccountName -> AccountName -> Bool +isAccountNamePrefixOf = isPrefixOf . (++ [acctsepchar]) + +isSubAccountNameOf :: AccountName -> AccountName -> Bool +s `isSubAccountNameOf` p = + (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1)) + +-- | From a list of account names, select those which are direct +-- subaccounts of the given account name. +subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName] +subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts + +-- | Convert a list of account names to a tree. +accountNameTreeFrom :: [AccountName] -> Tree AccountName +accountNameTreeFrom = accountNameTreeFrom1 + +accountNameTreeFrom1 accts = + Node "top" (accounttreesfrom (topAccountNames accts)) + where + accounttreesfrom :: [AccountName] -> [Tree AccountName] + accounttreesfrom [] = [] + accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as] + subs = subAccountNamesFrom (expandAccountNames accts) + +nullaccountnametree = Node "top" [] + +accountNameTreeFrom2 accts = + Node "top" $ unfoldForest (\a -> (a, subs a)) $ topAccountNames accts + where + subs = subAccountNamesFrom allaccts + allaccts = expandAccountNames accts + -- subs' a = subsmap ! a + -- subsmap :: Map AccountName [AccountName] + -- subsmap = Data.Map.fromList [(a, subAccountNamesFrom allaccts a) | a <- allaccts] + +accountNameTreeFrom3 accts = + Node "top" $ forestfrom allaccts $ topAccountNames accts + where + -- drop accts from the list of potential subs as we add them to the tree + forestfrom :: [AccountName] -> [AccountName] -> Forest AccountName + forestfrom subaccts accts = + [let subaccts' = subaccts \\ accts in Node a $ forestfrom subaccts' (subAccountNamesFrom subaccts' a) | a <- accts] + allaccts = expandAccountNames accts + + +-- a more efficient tree builder from Cale Gibbard +newtype Tree' a = T (Map a (Tree' a)) + deriving (Show, Eq, Ord) + +mergeTrees :: (Ord a) => Tree' a -> Tree' a -> Tree' a +mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m') + +emptyTree = T M.empty + +pathtree :: [a] -> Tree' a +pathtree [] = T M.empty +pathtree (x:xs) = T (M.singleton x (pathtree xs)) + +fromPaths :: (Ord a) => [[a]] -> Tree' a +fromPaths = foldl' mergeTrees emptyTree . map pathtree + +-- the above, but trying to build Tree directly + +-- mergeTrees' :: (Ord a) => Tree a -> Tree a -> Tree a +-- mergeTrees' (Node m ms) (Node m' ms') = Node undefined (ms `union` ms') + +-- emptyTree' = Node "top" [] + +-- pathtree' :: [a] -> Tree a +-- pathtree' [] = Node undefined [] +-- pathtree' (x:xs) = Node x [pathtree' xs] + +-- fromPaths' :: (Ord a) => [[a]] -> Tree a +-- fromPaths' = foldl' mergeTrees' emptyTree' . map pathtree' + + +-- converttree :: [AccountName] -> Tree' AccountName -> [Tree AccountName] +-- converttree parents (T m) = [Node (accountNameFromComponents $ parents ++ [a]) (converttree (parents++[a]) b) | (a,b) <- M.toList m] + +-- accountNameTreeFrom4 :: [AccountName] -> Tree AccountName +-- accountNameTreeFrom4 accts = Node "top" (converttree [] $ fromPaths $ map accountNameComponents accts) + +converttree :: Tree' AccountName -> [Tree AccountName] +converttree (T m) = [Node a (converttree b) | (a,b) <- M.toList m] + +expandTreeNames :: Tree AccountName -> Tree AccountName +expandTreeNames (Node x ts) = Node x (map (treemap (\n -> accountNameFromComponents [x,n]) . expandTreeNames) ts) + +accountNameTreeFrom4 :: [AccountName] -> Tree AccountName +accountNameTreeFrom4 = Node "top" . map expandTreeNames . converttree . fromPaths . map accountNameComponents + + +-- | Elide an account name to fit in the specified width. +-- From the ledger 2.6 news: +-- +-- @ +-- What Ledger now does is that if an account name is too long, it will +-- start abbreviating the first parts of the account name down to two +-- letters in length. If this results in a string that is still too +-- long, the front will be elided -- not the end. For example: +-- +-- Expenses:Cash ; OK, not too long +-- Ex:Wednesday:Cash ; "Expenses" was abbreviated to fit +-- Ex:We:Afternoon:Cash ; "Expenses" and "Wednesday" abbreviated +-- ; Expenses:Wednesday:Afternoon:Lunch:Snack:Candy:Chocolate:Cash +-- ..:Af:Lu:Sn:Ca:Ch:Cash ; Abbreviated and elided! +-- @ +elideAccountName :: Int -> AccountName -> AccountName +elideAccountName width s = + elideLeft width $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s + where + elideparts :: Int -> [String] -> [String] -> [String] + elideparts width done ss + | length (accountNameFromComponents $ done++ss) <= width = done++ss + | length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss) + | otherwise = done++ss + +clipAccountName :: Int -> AccountName -> AccountName +clipAccountName n = accountNameFromComponents . take n . accountNameComponents + diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Amount.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-| +An 'Amount' is some quantity of money, shares, or anything else. + +A simple amount is a 'Commodity', quantity pair: + +@ + $1 + £-50 + EUR 3.44 + GOOG 500 + 1.5h + 90 apples + 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 \@: + +@ + EUR 3 \@ $1.35 +@ + +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.): + +@ + $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. + +-} + +module Hledger.Data.Amount +where +import Hledger.Data.Utils +import Hledger.Data.Types +import Hledger.Data.Commodity + + +instance Show Amount where show = showAmount +instance Show MixedAmount where show = showMixedAmount +deriving instance Show HistoricalPrice + +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 + (+) = amountop (+) + (-) = amountop (-) + (*) = amountop (*) + +instance Ord Amount where + compare (Amount ac aq ap) (Amount bc bq bp) = compare (ac,aq,ap) (bc,bq,bp) + +instance Num MixedAmount where + fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing] + negate (Mixed as) = Mixed $ map negateAmountPreservingPrice 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" + +instance Ord MixedAmount where + compare (Mixed as) (Mixed bs) = compare as bs + +negateAmountPreservingPrice a = (-a){price=price a} + +-- | Apply a binary arithmetic operator to two amounts, converting to the +-- second one's commodity (and display precision), discarding any price +-- information. (Using the second commodity is best since sum and other +-- folds start with a no-commodity amount.) +amountop :: (Double -> Double -> Double) -> Amount -> Amount -> Amount +amountop op a@(Amount _ _ _) (Amount bc bq _) = + Amount bc (quantity (convertAmountTo bc a) `op` bq) Nothing + +-- | Convert an amount to the specified commodity using the appropriate +-- exchange rate (which is currently always 1). +convertAmountTo :: Commodity -> Amount -> Amount +convertAmountTo c2 (Amount c1 q _) = Amount c2 (q * conversionRate c1 c2) Nothing + +-- | Convert mixed amount to the specified commodity +convertMixedAmountTo :: Commodity -> MixedAmount -> Amount +convertMixedAmountTo c2 (Mixed ams) = Amount c2 total Nothing + where + total = sum . map (quantity . convertAmountTo c2) $ ams + +-- | Convert an amount to the commodity of its saved price, if any. +costOfAmount :: Amount -> Amount +costOfAmount a@(Amount _ _ Nothing) = a +costOfAmount (Amount _ q (Just price)) + | isZeroMixedAmount price = nullamt + | otherwise = Amount pc (pq*q) Nothing + where (Amount pc pq _) = head $ amounts price + +-- | Get the string representation of an amount, based on its commodity's +-- display settings. +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) = + case side of + L -> printf "%s%s%s%s" sym space quantity price + R -> printf "%s%s%s%s" quantity space sym price + where + space = if spaced then " " else "" + quantity = showAmount' a + price = case pri of (Just pamt) -> " @ " ++ showMixedAmount pamt + Nothing -> "" + +-- 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}" + (show c) (show q) (maybe "" showMixedAmountDebug pri) + +-- | Get the string representation of an amount, without any \@ price. +showAmountWithoutPrice :: Amount -> String +showAmountWithoutPrice a = showAmount a{price=Nothing} + +-- | Get the string representation (of the number part of) of an amount +showAmount' :: Amount -> String +showAmount' (Amount (Commodity {comma=comma,precision=p}) q _) = quantity + where + quantity = commad $ printf ("%."++show p++"f") q + commad = if comma then punctuatethousands else id + +-- | 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) + +-- | Does this amount appear to be zero when displayed with its given precision ? +isZeroAmount :: Amount -> Bool +isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPrice + +-- | 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 "%.10f" . quantity + +-- | Access a mixed amount's components. +amounts :: MixedAmount -> [Amount] +amounts (Mixed as) = as + +-- | Does this mixed amount appear to be zero - empty, or +-- containing only simple amounts which appear to be zero ? +isZeroMixedAmount :: MixedAmount -> Bool +isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmount + +-- | Is this mixed amount "really" zero ? See isReallyZeroAmount. +isReallyZeroMixedAmount :: MixedAmount -> Bool +isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmount + +-- | 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. +mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool +mixedAmountEquals a b = amounts a' == amounts b' || (isZeroMixedAmount a' && isZeroMixedAmount b') + where a' = normaliseMixedAmount a + b' = normaliseMixedAmount b + +-- | Get the string representation of a mixed amount, showing each of +-- its component amounts. NB a mixed amount can have an empty amounts +-- list in which case it shows as \"\". +showMixedAmount :: MixedAmount -> String +showMixedAmount m = vConcatRightAligned $ map show $ amounts $ normaliseMixedAmount m + +-- | Get an unambiguous string representation of a mixed amount for debugging. +showMixedAmountDebug :: MixedAmount -> String +showMixedAmountDebug m = printf "Mixed [%s]" as + where as = intercalate "\n " $ map showAmountDebug $ amounts $ normaliseMixedAmount m + +-- | Get the string representation of a mixed amount, but without +-- any \@ prices. +showMixedAmountWithoutPrice :: MixedAmount -> String +showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth as + where + (Mixed as) = normaliseMixedAmountIgnoringPrice m + 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 combining any component amounts which have +-- the same commodity and the same price. Also removes zero amounts, +-- or adds a single zero amount if there are no amounts at all. +normaliseMixedAmount :: MixedAmount -> MixedAmount +normaliseMixedAmount (Mixed as) = Mixed as'' + where + as'' = map sumSamePricedAmountsPreservingPrice $ 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 + +-- 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 (convertAmountTo 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 + +-- | 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 Commodity {symbol="AUTO",side=L,spaced=False,comma=False,precision=0} 0 Nothing] + + +tests_Amount = TestList [ + + "showMixedAmount" ~: do + showMixedAmount (Mixed [Amount dollar 0 Nothing]) `is` "$0.00" + showMixedAmount (Mixed []) `is` "0" + showMixedAmount missingamt `is` "" + + ,"showMixedAmountOrZero" ~: do + showMixedAmountOrZero (Mixed [Amount dollar 0 Nothing]) `is` "0" + showMixedAmountOrZero (Mixed []) `is` "0" + showMixedAmountOrZero missingamt `is` "" + + ,"amount arithmetic" ~: do + let a1 = dollars 1.23 + let a2 = Amount (comm "$") (-1.23) Nothing + let a3 = Amount (comm "$") (-1.23) Nothing + (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 + 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) + + ,"mixed amount arithmetic" ~: do + let dollar0 = dollar{precision=0} + (sum $ map (Mixed . (\a -> [a])) + [Amount dollar 1.25 Nothing, + Amount dollar0 (-1) Nothing, + Amount dollar (-0.25) Nothing]) + `is` Mixed [Amount dollar 0 Nothing] + + + ] diff --git a/Hledger/Data/Commodity.hs b/Hledger/Data/Commodity.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Commodity.hs @@ -0,0 +1,39 @@ +{-| + +A 'Commodity' is a symbol representing a currency or some other kind of +thing we are tracking, and some display preferences that tell how to +display 'Amount's of the commodity - is the symbol on the left or right, +are thousands separated by comma, significant decimal places and so on. + +-} +module Hledger.Data.Commodity +where +import Hledger.Data.Utils +import Hledger.Data.Types + + +-- convenient amount and commodity constructors, for tests etc. + +unknown = Commodity {symbol="", side=L,spaced=False,comma=False,precision=0} +dollar = Commodity {symbol="$", side=L,spaced=False,comma=False,precision=2} +euro = Commodity {symbol="EUR",side=L,spaced=False,comma=False,precision=2} +pound = Commodity {symbol="£", side=L,spaced=False,comma=False,precision=2} +hour = Commodity {symbol="h", side=R,spaced=False,comma=False,precision=1} + +dollars n = Amount dollar n Nothing +euros n = Amount euro n Nothing +pounds n = Amount pound n Nothing +hours n = Amount hour n Nothing + +defaultcommodities = [dollar, euro, pound, hour, unknown] + +-- | Look up one of the hard-coded default commodities. For use in tests. +comm :: String -> Commodity +comm sym = fromMaybe + (error "commodity lookup failed") + $ find (\(Commodity{symbol=s}) -> s==sym) defaultcommodities + +-- | Find the conversion rate between two commodities. Currently returns 1. +conversionRate :: Commodity -> Commodity -> Double +conversionRate _ _ = 1 + diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Dates.hs @@ -0,0 +1,471 @@ +{-| + +Date parsing and utilities for hledger. + +For date and time values, we use the standard Day and UTCTime types. + +A 'SmartDate' is a date which may be partially-specified or relative. +Eg 2008\/12\/31, but also 2008\/12, 12\/31, tomorrow, last week, next year. +We represent these as a triple of strings like (\"2008\",\"12\",\"\"), +(\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\"). + +A 'DateSpan' is the span of time between two specific calendar dates, or +an open-ended span where one or both dates are unspecified. (A date span +with both ends unspecified matches all dates.) + +An 'Interval' is ledger's "reporting interval" - weekly, monthly, +quarterly, etc. + +-} + +module Hledger.Data.Dates +where + +import Data.Time.Format +import Data.Time.Calendar.OrdinalDate +import Safe (readMay) +import System.Locale (defaultTimeLocale) +import Text.ParserCombinators.Parsec +import Hledger.Data.Types +import Hledger.Data.Utils + + +showDate :: Day -> String +showDate = formatTime defaultTimeLocale "%C%y/%m/%d" + +getCurrentDay :: IO Day +getCurrentDay = do + t <- getZonedTime + return $ localDay (zonedTimeToLocalTime t) + +elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a +elapsedSeconds t1 = realToFrac . diffUTCTime t1 + +-- | Split a DateSpan into one or more consecutive spans at the specified interval. +splitSpan :: Interval -> DateSpan -> [DateSpan] +splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] +splitSpan NoInterval s = [s] +splitSpan Daily s = splitspan startofday nextday s +splitSpan Weekly s = splitspan startofweek nextweek s +splitSpan Monthly s = splitspan startofmonth nextmonth s +splitSpan Quarterly s = splitspan startofquarter nextquarter s +splitSpan Yearly s = splitspan startofyear nextyear s + +splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan] +splitspan _ _ (DateSpan Nothing Nothing) = [] +splitspan start next (DateSpan Nothing (Just e)) = [DateSpan (Just $ start e) (Just $ next $ start e)] +splitspan start next (DateSpan (Just b) Nothing) = [DateSpan (Just $ start b) (Just $ next $ start b)] +splitspan start next span@(DateSpan (Just b) (Just e)) + | b == e = [span] + | otherwise = splitspan' start next span + where + splitspan' start next (DateSpan (Just b) (Just e)) + | b >= e = [] + | otherwise = DateSpan (Just s) (Just n) + : splitspan' start next (DateSpan (Just n) (Just e)) + where s = start b + n = next s + splitspan' _ _ _ = error "won't happen, avoids warnings" + +-- | Count the days in a DateSpan, or if it is open-ended return Nothing. +daysInSpan :: DateSpan -> Maybe Integer +daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays d2 d1 +daysInSpan _ = Nothing + +-- | Parse a period expression to an Interval and overall DateSpan using +-- the provided reference date, or raise an error. +parsePeriodExpr :: Day -> String -> (Interval, DateSpan) +parsePeriodExpr refdate expr = (interval,span) + where (interval,span) = fromparse $ parsewith (periodexpr refdate) expr + +-- | Convert a single smart date string to a date span using the provided +-- reference date, or raise an error. +spanFromSmartDateString :: Day -> String -> DateSpan +spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate + where + sdate = fromparse $ parsewith smartdateonly s + +spanFromSmartDate :: Day -> SmartDate -> DateSpan +spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e) + where + (ry,rm,_) = toGregorian refdate + (b,e) = span sdate + span :: SmartDate -> (Day,Day) + span ("","","today") = (refdate, nextday refdate) + span ("","this","day") = (refdate, nextday refdate) + span ("","","yesterday") = (prevday refdate, refdate) + span ("","last","day") = (prevday refdate, refdate) + span ("","","tomorrow") = (nextday refdate, addDays 2 refdate) + span ("","next","day") = (nextday refdate, addDays 2 refdate) + span ("","last","week") = (prevweek refdate, thisweek refdate) + span ("","this","week") = (thisweek refdate, nextweek refdate) + span ("","next","week") = (nextweek refdate, startofweek $ addDays 14 refdate) + span ("","last","month") = (prevmonth refdate, thismonth refdate) + span ("","this","month") = (thismonth refdate, nextmonth refdate) + span ("","next","month") = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate) + span ("","last","quarter") = (prevquarter refdate, thisquarter refdate) + span ("","this","quarter") = (thisquarter refdate, nextquarter refdate) + span ("","next","quarter") = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate) + span ("","last","year") = (prevyear refdate, thisyear refdate) + span ("","this","year") = (thisyear refdate, nextyear refdate) + span ("","next","year") = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate) + span ("","",d) = (day, nextday day) where day = fromGregorian ry rm (read d) + span ("",m,"") = (startofmonth day, nextmonth day) where day = fromGregorian ry (read m) 1 + span ("",m,d) = (day, nextday day) where day = fromGregorian ry (read m) (read d) + span (y,"","") = (startofyear day, nextyear day) where day = fromGregorian (read y) 1 1 + span (y,m,"") = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1 + span (y,m,d) = (day, nextday day) where day = fromGregorian (read y) (read m) (read d) + +showDay :: Day -> String +showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day + +-- | 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 + +-- | 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 + +-- | Convert a SmartDate to an absolute date using the provided reference date. +fixSmartDate :: Day -> SmartDate -> Day +fixSmartDate refdate sdate = fix sdate + where + fix :: SmartDate -> Day + fix ("","","today") = fromGregorian ry rm rd + fix ("","this","day") = fromGregorian ry rm rd + fix ("","","yesterday") = prevday refdate + fix ("","last","day") = prevday refdate + fix ("","","tomorrow") = nextday refdate + fix ("","next","day") = nextday refdate + fix ("","last","week") = prevweek refdate + fix ("","this","week") = thisweek refdate + fix ("","next","week") = nextweek refdate + fix ("","last","month") = prevmonth refdate + fix ("","this","month") = thismonth refdate + fix ("","next","month") = nextmonth refdate + fix ("","last","quarter") = prevquarter refdate + fix ("","this","quarter") = thisquarter refdate + fix ("","next","quarter") = nextquarter refdate + fix ("","last","year") = prevyear refdate + fix ("","this","year") = thisyear refdate + fix ("","next","year") = nextyear refdate + fix ("","",d) = fromGregorian ry rm (read d) + fix ("",m,"") = fromGregorian ry (read m) 1 + fix ("",m,d) = fromGregorian ry (read m) (read d) + fix (y,"","") = fromGregorian (read y) 1 1 + fix (y,m,"") = fromGregorian (read y) (read m) 1 + fix (y,m,d) = fromGregorian (read y) (read m) (read d) + (ry,rm,rd) = toGregorian refdate + +prevday :: Day -> Day +prevday = addDays (-1) +nextday = addDays 1 +startofday = id + +thisweek = startofweek +prevweek = startofweek . addDays (-7) +nextweek = startofweek . addDays 7 +startofweek day = fromMondayStartWeek y w 1 + where + (y,_,_) = toGregorian day + (w,_) = mondayStartWeek day + +thismonth = startofmonth +prevmonth = startofmonth . addGregorianMonthsClip (-1) +nextmonth = startofmonth . addGregorianMonthsClip 1 +startofmonth day = fromGregorian y m 1 where (y,m,_) = toGregorian day + +thisquarter = startofquarter +prevquarter = startofquarter . addGregorianMonthsClip (-3) +nextquarter = startofquarter . addGregorianMonthsClip 3 +startofquarter day = fromGregorian y (firstmonthofquarter m) 1 + where + (y,m,_) = toGregorian day + firstmonthofquarter m = ((m-1) `div` 3) * 3 + 1 + +thisyear = startofyear +prevyear = startofyear . addGregorianYearsClip (-1) +nextyear = startofyear . addGregorianYearsClip 1 +startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day + +---------------------------------------------------------------------- +-- parsing + +firstJust ms = case dropWhile (==Nothing) ms of + [] -> Nothing + (md:_) -> md + +-- | Parse a couple of date-time string formats to a time type. +parsedatetimeM :: String -> Maybe LocalTime +parsedatetimeM s = firstJust [ + parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s, + parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s + ] + +-- | Parse a couple of date string formats to a time type. +parsedateM :: String -> Maybe Day +parsedateM s = firstJust [ + parseTime defaultTimeLocale "%Y/%m/%d" s, + parseTime defaultTimeLocale "%Y-%m-%d" s + ] + +-- | Parse a date-time string to a time type, or raise an error. +parsedatetime :: String -> LocalTime +parsedatetime s = fromMaybe (error $ "could not parse timestamp \"" ++ s ++ "\"") + (parsedatetimeM s) + +-- | Parse a date string to a time type, or raise an error. +parsedate :: String -> Day +parsedate s = fromMaybe (error $ "could not parse date \"" ++ s ++ "\"") + (parsedateM s) + +-- | Parse a time string to a time type using the provided pattern, or +-- return the default. +parsetimewith :: ParseTime t => String -> String -> t -> t +parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s + +{-| +Parse a date in any of the formats allowed in ledger's period expressions, +and maybe some others: + +> 2004 +> 2004/10 +> 2004/10/1 +> 10/1 +> 21 +> october, oct +> yesterday, today, tomorrow +> (not yet) this/next/last week/day/month/quarter/year + +Returns a SmartDate, to be converted to a full date later (see fixSmartDate). +Assumes any text in the parse stream has been lowercased. +-} +smartdate :: GenParser Char st SmartDate +smartdate = do + (y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing] + return (y,m,d) + +-- | Like smartdate, but there must be nothing other than whitespace after the date. +smartdateonly :: GenParser Char st SmartDate +smartdateonly = do + d <- smartdate + many spacenonewline + eof + return d + +datesepchar = oneOf "/-." + +validYear, validMonth, validDay :: String -> Bool +validYear s = length s >= 4 && isJust (readMay s :: Maybe Int) +validMonth s = maybe False (\n -> n>=1 && n<=12) $ readMay s +validDay s = maybe False (\n -> n>=1 && n<=31) $ readMay s + +-- failIfInvalidYear, failIfInvalidMonth, failIfInvalidDay :: a +failIfInvalidYear s = unless (validYear s) $ fail $ "bad year number: " ++ s +failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s +failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s + +yyyymmdd :: GenParser Char st SmartDate +yyyymmdd = do + y <- count 4 digit + m <- count 2 digit + failIfInvalidMonth m + d <- count 2 digit + failIfInvalidDay d + return (y,m,d) + +ymd :: GenParser Char st SmartDate +ymd = do + y <- many1 digit + failIfInvalidYear y + datesepchar + m <- many1 digit + failIfInvalidMonth m + datesepchar + d <- many1 digit + failIfInvalidDay d + return $ (y,m,d) + +ym :: GenParser Char st SmartDate +ym = do + y <- many1 digit + failIfInvalidYear y + datesepchar + m <- many1 digit + failIfInvalidMonth m + return (y,m,"") + +y :: GenParser Char st SmartDate +y = do + y <- many1 digit + failIfInvalidYear y + return (y,"","") + +d :: GenParser Char st SmartDate +d = do + d <- many1 digit + failIfInvalidDay d + return ("","",d) + +md :: GenParser Char st SmartDate +md = do + m <- many1 digit + failIfInvalidMonth m + datesepchar + d <- many1 digit + failIfInvalidDay d + return ("",m,d) + +months = ["january","february","march","april","may","june", + "july","august","september","october","november","december"] +monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"] +weekdays = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"] +weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"] + +monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months +monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs + +month :: GenParser Char st SmartDate +month = do + m <- choice $ map (try . string) months + let i = monthIndex m + return ("",show i,"") + +mon :: GenParser Char st SmartDate +mon = do + m <- choice $ map (try . string) monthabbrevs + let i = monIndex m + return ("",show i,"") + +today,yesterday,tomorrow :: GenParser Char st SmartDate +today = string "today" >> return ("","","today") +yesterday = string "yesterday" >> return ("","","yesterday") +tomorrow = string "tomorrow" >> return ("","","tomorrow") + +lastthisnextthing :: GenParser Char st SmartDate +lastthisnextthing = do + r <- choice [ + string "last" + ,string "this" + ,string "next" + ] + many spacenonewline -- make the space optional for easier scripting + p <- choice [ + string "day" + ,string "week" + ,string "month" + ,string "quarter" + ,string "year" + ] +-- XXX support these in fixSmartDate +-- ++ (map string $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs) + + return ("",r,p) + +periodexpr :: Day -> GenParser Char st (Interval, DateSpan) +periodexpr rdate = choice $ map try [ + intervalanddateperiodexpr rdate, + intervalperiodexpr, + dateperiodexpr rdate, + (return (NoInterval,DateSpan Nothing Nothing)) + ] + +intervalanddateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) +intervalanddateperiodexpr rdate = do + many spacenonewline + i <- periodexprinterval + many spacenonewline + s <- periodexprdatespan rdate + return (i,s) + +intervalperiodexpr :: GenParser Char st (Interval, DateSpan) +intervalperiodexpr = do + many spacenonewline + i <- periodexprinterval + return (i, DateSpan Nothing Nothing) + +dateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) +dateperiodexpr rdate = do + many spacenonewline + s <- periodexprdatespan rdate + return (NoInterval, s) + +periodexprinterval :: GenParser Char st Interval +periodexprinterval = + choice $ map try [ + tryinterval "day" "daily" Daily, + tryinterval "week" "weekly" Weekly, + tryinterval "month" "monthly" Monthly, + tryinterval "quarter" "quarterly" Quarterly, + tryinterval "year" "yearly" Yearly + ] + where + tryinterval s1 s2 v = + choice [try (string $ "every "++s1), try (string s2)] >> return v + +periodexprdatespan :: Day -> GenParser Char st DateSpan +periodexprdatespan rdate = choice $ map try [ + doubledatespan rdate, + fromdatespan rdate, + todatespan rdate, + justdatespan rdate + ] + +doubledatespan :: Day -> GenParser Char st DateSpan +doubledatespan rdate = do + optional (string "from" >> many spacenonewline) + b <- smartdate + many spacenonewline + optional (string "to" >> many spacenonewline) + e <- smartdate + return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) + +fromdatespan :: Day -> GenParser Char st DateSpan +fromdatespan rdate = do + string "from" >> many spacenonewline + b <- smartdate + return $ DateSpan (Just $ fixSmartDate rdate b) Nothing + +todatespan :: Day -> GenParser Char st DateSpan +todatespan rdate = do + string "to" >> many spacenonewline + e <- smartdate + return $ DateSpan Nothing (Just $ fixSmartDate rdate e) + +justdatespan :: Day -> GenParser Char st DateSpan +justdatespan rdate = do + optional (string "in" >> many spacenonewline) + d <- smartdate + return $ spanFromSmartDate rdate d + +mkdatespan :: String -> String -> DateSpan +mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate + +nulldatespan = DateSpan Nothing Nothing + +nulldate = parsedate "1900/01/01" + +tests_Dates = TestList [ + + "splitSpan" ~: do + let gives (interval, span) = (splitSpan interval span `is`) + (NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives` + [mkdatespan "2008/01/01" "2009/01/01"] + (Quarterly,mkdatespan "2008/01/01" "2009/01/01") `gives` + [mkdatespan "2008/01/01" "2008/04/01" + ,mkdatespan "2008/04/01" "2008/07/01" + ,mkdatespan "2008/07/01" "2008/10/01" + ,mkdatespan "2008/10/01" "2009/01/01" + ] + (Quarterly,nulldatespan) `gives` + [nulldatespan] + (Daily,mkdatespan "2008/01/01" "2008/01/01") `gives` + [mkdatespan "2008/01/01" "2008/01/01"] + (Quarterly,mkdatespan "2008/01/01" "2008/01/01") `gives` + [mkdatespan "2008/01/01" "2008/01/01"] + + ] diff --git a/Hledger/Data/IO.hs b/Hledger/Data/IO.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/IO.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} +{-| +Utilities for doing I/O with ledger files. +-} + +module Hledger.Data.IO +where +import Control.Monad.Error +import Hledger.Data.Parse (parseJournal) +import Hledger.Data.Types (FilterSpec(..),WhichDate(..),Journal(..)) +import Hledger.Data.Dates (nulldatespan) +import System.Directory (getHomeDirectory) +import System.Environment (getEnv) +#if __GLASGOW_HASKELL__ <= 610 +import Prelude hiding (readFile) +import System.IO.UTF8 +#endif +import System.FilePath (()) + + +ledgerenvvar = "LEDGER" +timelogenvvar = "TIMELOG" +ledgerdefaultfilename = ".ledger" +timelogdefaultfilename = ".timelog" + +nullfilterspec = FilterSpec { + datespan=nulldatespan + ,cleared=Nothing + ,real=False + ,empty=False + ,costbasis=False + ,acctpats=[] + ,descpats=[] + ,whichdate=ActualDate + ,depth=Nothing + } + +-- | Get the user's default ledger file path. +myLedgerPath :: IO String +myLedgerPath = + getEnv ledgerenvvar `catch` + (\_ -> do + home <- getHomeDirectory `catch` (\_ -> return "") + return $ home ledgerdefaultfilename) + +-- | Get the user's default timelog file path. +myTimelogPath :: IO String +myTimelogPath = + getEnv timelogenvvar `catch` + (\_ -> do + home <- getHomeDirectory + return $ home timelogdefaultfilename) + +-- | Read the user's default journal file, or give an error. +myJournal :: IO Journal +myJournal = myLedgerPath >>= readJournal + +-- | Read the user's default timelog file, or give an error. +myTimelog :: IO Journal +myTimelog = myTimelogPath >>= readJournal + +-- | Read a journal from this file, or throw an error. +readJournal :: FilePath -> IO Journal +readJournal f = do + s <- readFile f + j <- journalFromString s + return j{filepath=f} + +-- | Read a Journal from the given string, using the current time as +-- reference time, or throw an error. +journalFromString :: String -> IO Journal +journalFromString s = liftM (either error id) $ runErrorT $ parseJournal "(from string)" s + +-- -- | 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 + diff --git a/Hledger/Data/Journal.hs b/Hledger/Data/Journal.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Journal.hs @@ -0,0 +1,358 @@ +{-| + +A 'Journal' is a set of 'Transaction's and related data, usually parsed +from a hledger/ledger journal file or timelog. + +-} + +module Hledger.Data.Journal +where +import qualified Data.Map as Map +import Data.Map (findWithDefault, (!)) +import System.Time (ClockTime(TOD)) +import Hledger.Data.Utils +import Hledger.Data.Types +import Hledger.Data.AccountName +import Hledger.Data.Amount +import Hledger.Data.Transaction (ledgerTransactionWithDate) +import Hledger.Data.Posting +import Hledger.Data.TimeLog + + +instance Show Journal where + show j = printf "Journal %s with %d transactions, %d accounts: %s" + (filepath j) + (length (jtxns j) + + length (jmodifiertxns j) + + length (jperiodictxns j)) + (length accounts) + (show accounts) + -- ++ (show $ journalTransactions l) + where accounts = flatten $ journalAccountNameTree j + +nulljournal :: Journal +nulljournal = Journal { jmodifiertxns = [] + , jperiodictxns = [] + , jtxns = [] + , open_timelog_entries = [] + , historical_prices = [] + , final_comment_lines = [] + , filepath = "" + , filereadtime = TOD 0 0 + , jtext = "" + } + +addTransaction :: Transaction -> Journal -> Journal +addTransaction t l0 = l0 { jtxns = t : jtxns l0 } + +addModifierTransaction :: ModifierTransaction -> Journal -> Journal +addModifierTransaction mt l0 = l0 { jmodifiertxns = mt : jmodifiertxns l0 } + +addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal +addPeriodicTransaction pt l0 = l0 { jperiodictxns = pt : jperiodictxns l0 } + +addHistoricalPrice :: HistoricalPrice -> Journal -> Journal +addHistoricalPrice h l0 = l0 { historical_prices = h : historical_prices l0 } + +addTimeLogEntry :: TimeLogEntry -> Journal -> Journal +addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : open_timelog_entries l0 } + +journalPostings :: Journal -> [Posting] +journalPostings = concatMap tpostings . jtxns + +journalAccountNamesUsed :: Journal -> [AccountName] +journalAccountNamesUsed = accountNamesFromPostings . journalPostings + +journalAccountNames :: Journal -> [AccountName] +journalAccountNames = sort . expandAccountNames . journalAccountNamesUsed + +journalAccountNameTree :: Journal -> Tree AccountName +journalAccountNameTree = accountNameTreeFrom . journalAccountNames + +-- 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. +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 + +-- | 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. +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 . + filterJournalPostingsByClearedStatus cleared . + filterJournalPostingsByEmpty empty . + filterJournalPostingsByDepth depth . + filterJournalPostingsByAccount apats . + filterJournalTransactionsByDescription dpats . + filterJournalTransactionsByDate datespan . + journalSelectingDate whichdate + +-- | Keep only ledger transactions whose description matches the description patterns. +filterJournalTransactionsByDescription :: [String] -> Journal -> Journal +filterJournalTransactionsByDescription pats j@Journal{jtxns=ts} = j{jtxns=filter matchdesc ts} + where matchdesc = matchpats pats . tdescription + +-- | Keep only ledger transactions which fall between begin and end dates. +-- We include transactions on the begin date and exclude transactions on the end +-- date, like ledger. An empty date string means no restriction. +filterJournalTransactionsByDate :: DateSpan -> Journal -> Journal +filterJournalTransactionsByDate (DateSpan begin end) j@Journal{jtxns=ts} = j{jtxns=filter match ts} + where match t = maybe True (tdate t>=) begin && maybe True (tdate t<) end + +-- | Keep only ledger transactions which have the requested +-- cleared/uncleared status, if there is one. +filterJournalTransactionsByClearedStatus :: Maybe Bool -> Journal -> Journal +filterJournalTransactionsByClearedStatus Nothing j = j +filterJournalTransactionsByClearedStatus (Just val) j@Journal{jtxns=ts} = j{jtxns=filter match ts} + where match = (==val).tstatus + +-- | Keep only postings which have the requested cleared/uncleared status, +-- if there is one. +filterJournalPostingsByClearedStatus :: Maybe Bool -> Journal -> Journal +filterJournalPostingsByClearedStatus Nothing j = j +filterJournalPostingsByClearedStatus (Just c) j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} + where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter ((==c) . postingCleared) ps} + +-- | Strip out any virtual postings, if the flag is true, otherwise do +-- no filtering. +filterJournalPostingsByRealness :: Bool -> Journal -> Journal +filterJournalPostingsByRealness False l = l +filterJournalPostingsByRealness True j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} + where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter isReal ps} + +-- | Strip out any postings with zero amount, unless the flag is true. +filterJournalPostingsByEmpty :: Bool -> Journal -> Journal +filterJournalPostingsByEmpty True l = l +filterJournalPostingsByEmpty False j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} + where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (not . isEmptyPosting) ps} + +-- | Keep only transactions which affect accounts deeper than the specified depth. +filterJournalTransactionsByDepth :: Maybe Int -> Journal -> Journal +filterJournalTransactionsByDepth Nothing j = j +filterJournalTransactionsByDepth (Just d) j@Journal{jtxns=ts} = + j{jtxns=(filter (any ((<= d+1) . accountNameLevel . paccount) . tpostings) ts)} + +-- | Strip out any postings to accounts deeper than the specified depth +-- (and any ledger transactions which have no postings as a result). +filterJournalPostingsByDepth :: Maybe Int -> Journal -> Journal +filterJournalPostingsByDepth Nothing j = j +filterJournalPostingsByDepth (Just d) j@Journal{jtxns=ts} = + j{jtxns=filter (not . null . tpostings) $ map filtertxns ts} + where filtertxns t@Transaction{tpostings=ps} = + t{tpostings=filter ((<= d) . accountNameLevel . paccount) ps} + +-- | Keep only transactions which affect accounts matched by the account patterns. +-- More precisely: each positive account pattern excludes transactions +-- which do not contain a posting to a matched account, and each negative +-- account pattern excludes transactions containing a posting to a matched +-- account. +filterJournalTransactionsByAccount :: [String] -> Journal -> Journal +filterJournalTransactionsByAccount apats j@Journal{jtxns=ts} = j{jtxns=filter tmatch ts} + where + 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 + (negatives,positives) = partition isnegativepat apats + +-- | Keep only postings which affect accounts matched by the account patterns. +-- This can leave transactions unbalanced. +filterJournalPostingsByAccount :: [String] -> Journal -> Journal +filterJournalPostingsByAccount apats j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} + where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (matchpats apats . paccount) ps} + +-- | Convert this journal's transactions' primary date to either the +-- actual or effective date. +journalSelectingDate :: WhichDate -> Journal -> Journal +journalSelectingDate ActualDate j = j +journalSelectingDate EffectiveDate j = + j{jtxns=map (ledgerTransactionWithDate EffectiveDate) $ jtxns j} + +-- | Do post-parse processing on a journal, to make it ready for use. +journalFinalise :: ClockTime -> LocalTime -> FilePath -> String -> Journal -> Journal +journalFinalise tclock tlocal path txt j = journalCanonicaliseAmounts $ + journalApplyHistoricalPrices $ + journalCloseTimeLogEntries tlocal + j{filepath=path, filereadtime=tclock, jtext=txt} + +-- | Convert all the journal's amounts to their canonical display +-- settings. Ie, all amounts in a given commodity will use (a) the +-- display settings of the first, and (b) the greatest precision, of the +-- amounts in that commodity. Prices are canonicalised as well, so consider +-- calling journalApplyHistoricalPrices before this. +journalCanonicaliseAmounts :: Journal -> Journal +journalCanonicaliseAmounts j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} + where + 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 a@Amount{commodity=c,price=p} = a{commodity=fixcommodity c, price=maybe Nothing (Just . fixmixedamount) p} + fixcommodity c@Commodity{symbol=s} = findWithDefault c s canonicalcommoditymap + canonicalcommoditymap = journalCanonicalCommodities j + +-- | Apply this journal's historical price records to unpriced amounts where possible. +journalApplyHistoricalPrices :: Journal -> Journal +journalApplyHistoricalPrices j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} + where + fixtransaction t@Transaction{tdate=d, tpostings=ps} = t{tpostings=map fixposting ps} + where + fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a} + fixmixedamount (Mixed as) = Mixed $ map fixamount as + fixamount = fixprice + fixprice a@Amount{price=Just _} = a + fixprice a@Amount{commodity=c} = a{price=journalHistoricalPriceFor j d c} + +-- | Get the price for a commodity on the specified day from the price database, if known. +-- Does only one lookup step, ie will not look up the price of a price. +journalHistoricalPriceFor :: Journal -> Day -> Commodity -> Maybe MixedAmount +journalHistoricalPriceFor j d Commodity{symbol=s} = do + let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices j + case ps of (HistoricalPrice{hamount=a}:_) -> Just a + _ -> Nothing + +-- | Close any open timelog sessions in this journal using the provided current time. +journalCloseTimeLogEntries :: LocalTime -> Journal -> Journal +journalCloseTimeLogEntries now j@Journal{jtxns=ts, open_timelog_entries=es} = + j{jtxns = ts ++ (timeLogEntriesToTransactions now es), open_timelog_entries = []} + +-- | Convert all this journal's amounts to cost by applying their prices, if any. +journalConvertAmountsToCost :: Journal -> Journal +journalConvertAmountsToCost j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} + where + 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 = costOfAmount + +-- | Get this journal's unique, display-preference-canonicalised commodities, by symbol. +journalCanonicalCommodities :: Journal -> Map.Map String Commodity +journalCanonicalCommodities j = + Map.fromList [(s,firstc{precision=maxp}) | s <- commoditysymbols, + let cs = commoditymap ! s, + let firstc = head cs, + let maxp = maximum $ map precision cs + ] + where + commoditymap = Map.fromList [(s,commoditieswithsymbol s) | s <- commoditysymbols] + commoditieswithsymbol s = filter ((s==) . symbol) commodities + commoditysymbols = nub $ map symbol commodities + commodities = journalAmountAndPriceCommodities j + +-- | Get all this journal's amounts' commodities, in the order parsed. +journalAmountCommodities :: Journal -> [Commodity] +journalAmountCommodities = map commodity . concatMap amounts . journalAmounts + +-- | Get all this journal's amount and price commodities, in the order parsed. +journalAmountAndPriceCommodities :: Journal -> [Commodity] +journalAmountAndPriceCommodities = concatMap amountCommodities . concatMap amounts . journalAmounts + +-- | Get this amount's commodity and any commodities referenced in its price. +amountCommodities :: Amount -> [Commodity] +amountCommodities Amount{commodity=c,price=Nothing} = [c] +amountCommodities Amount{commodity=c,price=Just ma} = c:(concatMap amountCommodities $ amounts ma) + +-- | Get all this journal's amounts, in the order parsed. +journalAmounts :: Journal -> [MixedAmount] +journalAmounts = map pamount . journalPostings + +-- | The (fully specified) date span containing this journal's transactions, +-- or DateSpan Nothing Nothing if there are none. +journalDateSpan :: Journal -> DateSpan +journalDateSpan j + | null ts = DateSpan Nothing Nothing + | otherwise = DateSpan (Just $ tdate $ head ts) (Just $ addDays 1 $ tdate $ last ts) + where + ts = sortBy (comparing tdate) $ jtxns j + +-- | Check if a set of ledger account/description patterns matches the +-- given account name or entry description. Patterns are case-insensitive +-- regular expressions. Prefixed with not:, they become anti-patterns. +matchpats :: [String] -> String -> Bool +matchpats pats str = + (null positives || any match positives) && (null negatives || not (any match negatives)) + where + (negatives,positives) = partition isnegativepat pats + match "" = True + match pat = containsRegex (abspat pat) str + +negateprefix = "not:" + +isnegativepat = (negateprefix `isPrefixOf`) + +abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat + +-- | Calculate the account tree and all account balances from a journal's +-- postings, returning the results for efficient lookup. +journalAccountInfo :: Journal -> (Tree AccountName, Map.Map AccountName Account) +journalAccountInfo j = (ant, amap) + where + (ant, psof, _, inclbalof) = (groupPostings . journalPostings) j + amap = Map.fromList [(a, acctinfo a) | a <- flatten ant] + acctinfo a = Account a (psof a) (inclbalof a) + +-- | Given a list of postings, return an account name tree and three query +-- functions that fetch postings, subaccount-excluding-balance and +-- subaccount-including-balance by account name. +groupPostings :: [Posting] -> (Tree AccountName, + (AccountName -> [Posting]), + (AccountName -> MixedAmount), + (AccountName -> MixedAmount)) +groupPostings ps = (ant, psof, exclbalof, inclbalof) + where + anames = sort $ nub $ map paccount ps + ant = accountNameTreeFrom $ expandAccountNames anames + allanames = flatten ant + pmap = Map.union (postingsByAccount ps) (Map.fromList [(a,[]) | a <- allanames]) + psof = (pmap !) + balmap = Map.fromList $ flatten $ calculateBalances ant psof + exclbalof = fst . (balmap !) + inclbalof = snd . (balmap !) + +-- | Add subaccount-excluding and subaccount-including balances to a tree +-- of account names somewhat efficiently, given a function that looks up +-- transactions by account name. +calculateBalances :: Tree AccountName -> (AccountName -> [Posting]) -> Tree (AccountName, (MixedAmount, MixedAmount)) +calculateBalances ant psof = addbalances ant + where + addbalances (Node a subs) = Node (a,(bal,bal+subsbal)) subs' + where + bal = sumPostings $ psof a + subsbal = sum $ map (snd . snd . root) subs' + subs' = map addbalances subs + +-- | Convert a list of postings to a map from account name to that +-- account's postings. +postingsByAccount :: [Posting] -> Map.Map AccountName [Posting] +postingsByAccount ps = m' + where + sortedps = sortBy (comparing paccount) ps + groupedps = groupBy (\p1 p2 -> paccount p1 == paccount p2) sortedps + m' = Map.fromList [(paccount $ head g, g) | g <- groupedps] diff --git a/Hledger/Data/Ledger.hs b/Hledger/Data/Ledger.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Ledger.hs @@ -0,0 +1,122 @@ +{-| + +A 'Ledger' is derived from a 'Journal' by applying a filter specification +to select 'Transaction's and 'Posting's of interest. It contains the +filtered journal and knows the resulting chart of accounts, account +balances, and postings in each account. + +-} + +module Hledger.Data.Ledger +where +import Data.Map (Map, findWithDefault, fromList) +import Hledger.Data.Utils +import Hledger.Data.Types +import Hledger.Data.Account (nullacct) +import Hledger.Data.AccountName +import Hledger.Data.Journal +import Hledger.Data.Posting + + +instance Show Ledger where + show l = printf "Ledger with %d transactions, %d accounts\n%s" + (length (jtxns $ journal l) + + length (jmodifiertxns $ journal l) + + length (jperiodictxns $ journal l)) + (length $ accountnames l) + (showtree $ accountnametree l) + +nullledger :: Ledger +nullledger = Ledger{ + journal = nulljournal, + accountnametree = nullaccountnametree, + accountmap = fromList [] + } + +-- | Filter a ledger's transactions as specified and generate derived data. +journalToLedger :: FilterSpec -> Journal -> Ledger +journalToLedger fs j = nullledger{journal=j',accountnametree=t,accountmap=m} + where j' = filterJournalPostings fs{depth=Nothing} j + (t, m) = journalAccountInfo j' + +-- | List a ledger's account names. +ledgerAccountNames :: Ledger -> [AccountName] +ledgerAccountNames = drop 1 . flatten . accountnametree + +-- | Get the named account from a ledger. +ledgerAccount :: Ledger -> AccountName -> Account +ledgerAccount l a = findWithDefault nullacct a $ accountmap l + +-- | List a ledger's accounts, in tree order +ledgerAccounts :: Ledger -> [Account] +ledgerAccounts = drop 1 . flatten . ledgerAccountTree 9999 + +-- | List a ledger's top-level accounts, in tree order +ledgerTopAccounts :: Ledger -> [Account] +ledgerTopAccounts = map root . branches . ledgerAccountTree 9999 + +-- | Accounts in ledger whose name matches the pattern, in tree order. +ledgerAccountsMatching :: [String] -> Ledger -> [Account] +ledgerAccountsMatching pats = filter (matchpats pats . aname) . accounts + +-- | List a ledger account's immediate subaccounts +ledgerSubAccounts :: Ledger -> Account -> [Account] +ledgerSubAccounts l Account{aname=a} = + map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ accountnames l + +-- | List a ledger's postings, in the order parsed. +ledgerPostings :: Ledger -> [Posting] +ledgerPostings = journalPostings . journal + +-- | Get a ledger's tree of accounts to the specified depth. +ledgerAccountTree :: Int -> Ledger -> Tree Account +ledgerAccountTree depth l = treemap (ledgerAccount l) $ treeprune depth $ accountnametree l + +-- | Get a ledger's tree of accounts rooted at the specified account. +ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account) +ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l + +-- | The (fully specified) date span containing all the ledger's (filtered) transactions, +-- or DateSpan Nothing Nothing if there are none. +ledgerDateSpan :: Ledger -> DateSpan +ledgerDateSpan = postingsDateSpan . ledgerPostings + +-- | Convenience aliases. +accountnames :: Ledger -> [AccountName] +accountnames = ledgerAccountNames + +account :: Ledger -> AccountName -> Account +account = ledgerAccount + +accounts :: Ledger -> [Account] +accounts = ledgerAccounts + +topaccounts :: Ledger -> [Account] +topaccounts = ledgerTopAccounts + +accountsmatching :: [String] -> Ledger -> [Account] +accountsmatching = ledgerAccountsMatching + +subaccounts :: Ledger -> Account -> [Account] +subaccounts = ledgerSubAccounts + +postings :: Ledger -> [Posting] +postings = ledgerPostings + +commodities :: Ledger -> Map String Commodity +commodities = journalCanonicalCommodities . journal + +accounttree :: Int -> Ledger -> Tree Account +accounttree = ledgerAccountTree + +accounttreeat :: Ledger -> Account -> Maybe (Tree Account) +accounttreeat = ledgerAccountTreeAt + +-- datespan :: Ledger -> DateSpan +-- datespan = ledgerDateSpan + +rawdatespan :: Ledger -> DateSpan +rawdatespan = journalDateSpan . journal + +ledgeramounts :: Ledger -> [MixedAmount] +ledgeramounts = journalAmounts . journal diff --git a/Hledger/Data/Parse.hs b/Hledger/Data/Parse.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Parse.hs @@ -0,0 +1,731 @@ +{-# LANGUAGE CPP #-} +{-| + +Parsers for standard ledger and timelog files. + +Here is the ledger grammar from the ledger 2.5 manual: + +@ +The ledger file format is quite simple, but also very flexible. It supports +many options, though typically the user can ignore most of them. They are +summarized below. The initial character of each line determines what the +line means, and how it should be interpreted. Allowable initial characters +are: + +NUMBER A line beginning with a number denotes an entry. It may be followed by any + number of lines, each beginning with whitespace, to denote the entry’s account + transactions. The format of the first line is: + + DATE[=EDATE] [*|!] [(CODE)] DESC + + If ‘*’ appears after the date (with optional effective date), it indicates the entry + is “cleared”, which can mean whatever the user wants it t omean. If ‘!’ appears + after the date, it indicates d the entry is “pending”; i.e., tentatively cleared from + the user’s point of view, but not yet actually cleared. If a ‘CODE’ appears in + parentheses, it may be used to indicate a check number, or the type of the + transaction. Following these is the payee, or a description of the transaction. + The format of each following transaction is: + + ACCOUNT AMOUNT [; NOTE] + + The ‘ACCOUNT’ may be surrounded by parentheses if it is a virtual + transactions, or square brackets if it is a virtual transactions that must + balance. The ‘AMOUNT’ can be followed by a per-unit transaction cost, + by specifying ‘ AMOUNT’, or a complete transaction cost with ‘\@ AMOUNT’. + Lastly, the ‘NOTE’ may specify an actual and/or effective date for the + transaction by using the syntax ‘[ACTUAL_DATE]’ or ‘[=EFFECTIVE_DATE]’ or + ‘[ACTUAL_DATE=EFFECtIVE_DATE]’. + += An automated entry. A value expression must appear after the equal sign. + After this initial line there should be a set of one or more transactions, just as + if it were normal entry. If the amounts of the transactions have no commodity, + they will be applied as modifiers to whichever real transaction is matched by + the value expression. + +~ A period entry. A period expression must appear after the tilde. + After this initial line there should be a set of one or more transactions, just as + if it were normal entry. + +! A line beginning with an exclamation mark denotes a command directive. It + must be immediately followed by the command word. The supported commands + are: + + ‘!include’ + Include the stated ledger file. + ‘!account’ + The account name is given is taken to be the parent of all transac- + tions that follow, until ‘!end’ is seen. + ‘!end’ Ends an account block. + +; A line beginning with a colon indicates a comment, and is ignored. + +Y If a line begins with a capital Y, it denotes the year used for all subsequent + entries that give a date without a year. The year should appear immediately + after the Y, for example: ‘Y2004’. This is useful at the beginning of a file, to + specify the year for that file. If all entries specify a year, however, this command + has no effect. + + +P Specifies a historical price for a commodity. These are usually found in a pricing + history file (see the ‘-Q’ option). The syntax is: + + P DATE SYMBOL PRICE + +N SYMBOL Indicates that pricing information is to be ignored for a given symbol, nor will + quotes ever be downloaded for that symbol. Useful with a home currency, such + as the dollar ($). It is recommended that these pricing options be set in the price + database file, which defaults to ‘~/.pricedb’. The syntax for this command is: + + N SYMBOL + + +D AMOUNT Specifies the default commodity to use, by specifying an amount in the expected + format. The entry command will use this commodity as the default when none + other can be determined. This command may be used multiple times, to set + the default flags for different commodities; whichever is seen last is used as the + default commodity. For example, to set US dollars as the default commodity, + while also setting the thousands flag and decimal flag for that commodity, use: + + D $1,000.00 + +C AMOUNT1 = AMOUNT2 + Specifies a commodity conversion, where the first amount is given to be equiv- + alent to the second amount. The first amount should use the decimal precision + desired during reporting: + + C 1.00 Kb = 1024 bytes + +i, o, b, h + These four relate to timeclock support, which permits ledger to read timelog + files. See the timeclock’s documentation for more info on the syntax of its + timelog files. +@ + +Here is the timelog grammar from timeclock.el 2.6: + +@ +A timelog contains data in the form of a single entry per line. +Each entry has the form: + + CODE YYYY/MM/DD HH:MM:SS [COMMENT] + +CODE is one of: b, h, i, o or O. COMMENT is optional when the code is +i, o or O. The meanings of the codes are: + + b Set the current time balance, or \"time debt\". Useful when + archiving old log data, when a debt must be carried forward. + The COMMENT here is the number of seconds of debt. + + h Set the required working time for the given day. This must + be the first entry for that day. The COMMENT in this case is + the number of hours in this workday. Floating point amounts + are allowed. + + i Clock in. The COMMENT in this case should be the name of the + project worked on. + + o Clock out. COMMENT is unnecessary, but can be used to provide + a description of how the period went, for example. + + O Final clock out. Whatever project was being worked on, it is + now finished. Useful for creating summary reports. +@ + +Example: + +@ +i 2007/03/10 12:26:00 hledger +o 2007/03/10 17:26:02 +@ + +-} + +module Hledger.Data.Parse +where +import Control.Monad.Error (ErrorT(..), MonadIO, liftIO, throwError, catchError) +import Text.ParserCombinators.Parsec +import System.Directory +#if __GLASGOW_HASKELL__ <= 610 +import Prelude hiding (readFile, putStr, putStrLn, print, getContents) +import System.IO.UTF8 +#endif +import Hledger.Data.Utils +import Hledger.Data.Types +import Hledger.Data.Dates +import Hledger.Data.AccountName (accountNameFromComponents,accountNameComponents) +import Hledger.Data.Amount +import Hledger.Data.Transaction +import Hledger.Data.Posting +import Hledger.Data.Journal +import Hledger.Data.Commodity (dollars,dollar,unknown) +import System.FilePath(takeDirectory,combine) +import System.Time (getClockTime) + + +-- | A JournalUpdate is some transformation of a "Journal". It can do I/O +-- or raise an error. +type JournalUpdate = ErrorT String IO (Journal -> Journal) + +-- | Some context kept during parsing. +data LedgerFileCtx = Ctx { + ctxYear :: !(Maybe Integer) -- ^ the default year most recently specified with Y + , ctxCommod :: !(Maybe String) -- ^ I don't know + , ctxAccount :: ![String] -- ^ the current stack of parent accounts specified by !account + } deriving (Read, Show) + +emptyCtx :: LedgerFileCtx +emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] } + +setYear :: Integer -> GenParser tok LedgerFileCtx () +setYear y = updateState (\ctx -> ctx{ctxYear=Just y}) + +getYear :: GenParser tok LedgerFileCtx (Maybe Integer) +getYear = liftM ctxYear getState + +pushParentAccount :: String -> GenParser tok LedgerFileCtx () +pushParentAccount parent = updateState addParentAccount + where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 } + normalize = (++ ":") + +popParentAccount :: GenParser tok LedgerFileCtx () +popParentAccount = do ctx0 <- getState + case ctxAccount ctx0 of + [] -> unexpected "End of account block with no beginning" + (_:rest) -> setState $ ctx0 { ctxAccount = rest } + +getParentAccount :: GenParser tok LedgerFileCtx String +getParentAccount = liftM (concat . reverse . ctxAccount) getState + +expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath +expandPath pos fp = liftM mkRelative (expandHome fp) + where + mkRelative = combine (takeDirectory (sourceName pos)) + expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory + return $ homedir ++ drop 1 inname + | otherwise = return inname + +-- let's get to it + +-- | Parse and post-process a journal file or timelog file to a "Journal", +-- or give an error. +parseJournalFile :: FilePath -> ErrorT String IO Journal +parseJournalFile "-" = liftIO getContents >>= parseJournal "-" +parseJournalFile f = liftIO (readFile f) >>= parseJournal f + +-- | Parse and post-process a "Journal" from a string, saving the provided +-- file path and the current time, or give an error. +parseJournal :: FilePath -> String -> ErrorT String IO Journal +parseJournal f s = do + tc <- liftIO getClockTime + tl <- liftIO getCurrentLocalTime + case runParser ledgerFile emptyCtx f s of + Right m -> liftM (journalFinalise tc tl f s) $ m `ap` return nulljournal + Left err -> throwError $ show err -- XXX raises an uncaught exception if we have a parsec user error, eg from many ? + +-- | Top-level journal parser. Returns a single composite, I/O performing, +-- error-raising "JournalUpdate" which can be applied to an empty journal +-- to get the final result. +ledgerFile :: GenParser Char LedgerFileCtx JournalUpdate +ledgerFile = do items <- many ledgerItem + eof + return $ liftM (foldr (.) id) $ sequence items + where + -- 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 + ledgerItem = choice [ ledgerExclamationDirective + , liftM (return . addTransaction) ledgerTransaction + , liftM (return . addModifierTransaction) ledgerModifierTransaction + , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction + , liftM (return . addHistoricalPrice) ledgerHistoricalPrice + , ledgerDefaultYear + , ledgerIgnoredPriceCommodity + , ledgerTagDirective + , ledgerEndTagDirective + , emptyLine >> return (return id) + , liftM (return . addTimeLogEntry) timelogentry + ] "ledger transaction, timelog entry, or directive" + +emptyLine :: GenParser Char st () +emptyLine = do many spacenonewline + optional $ (char ';' "comment") >> many (noneOf "\n") + newline + return () + +ledgercomment :: GenParser Char st String +ledgercomment = do + many1 $ char ';' + many spacenonewline + many (noneOf "\n") + "comment" + +ledgercommentline :: GenParser Char st String +ledgercommentline = do + many spacenonewline + s <- ledgercomment + optional newline + eof + return s + "comment" + +ledgerExclamationDirective :: GenParser Char LedgerFileCtx JournalUpdate +ledgerExclamationDirective = do + char '!' "directive" + directive <- many nonspace + case directive of + "include" -> ledgerInclude + "account" -> ledgerAccountBegin + "end" -> ledgerAccountEnd + _ -> mzero + +ledgerInclude :: GenParser Char LedgerFileCtx JournalUpdate +ledgerInclude = do many1 spacenonewline + filename <- restofline + outerState <- getState + outerPos <- getPosition + let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n" + return $ do contents <- expandPath outerPos filename >>= readFileE outerPos + case runParser ledgerFile outerState filename contents of + Right l -> l `catchError` (throwError . (inIncluded ++)) + Left perr -> throwError $ inIncluded ++ show perr + where readFileE outerPos filename = ErrorT $ liftM Right (readFile filename) `catch` leftError + where leftError err = return $ Left $ currentPos ++ whileReading ++ show err + currentPos = show outerPos + whileReading = " reading " ++ show filename ++ ":\n" + +ledgerAccountBegin :: GenParser Char LedgerFileCtx JournalUpdate +ledgerAccountBegin = do many1 spacenonewline + parent <- ledgeraccountname + newline + pushParentAccount parent + return $ return id + +ledgerAccountEnd :: GenParser Char LedgerFileCtx JournalUpdate +ledgerAccountEnd = popParentAccount >> return (return id) + +ledgerModifierTransaction :: GenParser Char LedgerFileCtx ModifierTransaction +ledgerModifierTransaction = do + char '=' "modifier transaction" + many spacenonewline + valueexpr <- restofline + postings <- ledgerpostings + return $ ModifierTransaction valueexpr postings + +ledgerPeriodicTransaction :: GenParser Char LedgerFileCtx PeriodicTransaction +ledgerPeriodicTransaction = do + char '~' "periodic transaction" + many spacenonewline + periodexpr <- restofline + postings <- ledgerpostings + return $ PeriodicTransaction periodexpr postings + +ledgerHistoricalPrice :: GenParser Char LedgerFileCtx 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 LedgerFileCtx JournalUpdate +ledgerIgnoredPriceCommodity = do + char 'N' "ignored-price commodity" + many1 spacenonewline + commoditysymbol + restofline + return $ return id + +ledgerDefaultCommodity :: GenParser Char LedgerFileCtx JournalUpdate +ledgerDefaultCommodity = do + char 'D' "default commodity" + many1 spacenonewline + someamount + restofline + return $ return id + +ledgerCommodityConversion :: GenParser Char LedgerFileCtx JournalUpdate +ledgerCommodityConversion = do + char 'C' "commodity conversion" + many1 spacenonewline + someamount + many spacenonewline + char '=' + many spacenonewline + someamount + restofline + return $ return id + +ledgerTagDirective :: GenParser Char LedgerFileCtx JournalUpdate +ledgerTagDirective = do + string "tag" "tag directive" + many1 spacenonewline + _ <- many1 nonspace + restofline + return $ return id + +ledgerEndTagDirective :: GenParser Char LedgerFileCtx JournalUpdate +ledgerEndTagDirective = do + string "end tag" "end tag directive" + restofline + return $ return id + +-- like ledgerAccountBegin, updates the LedgerFileCtx +ledgerDefaultYear :: GenParser Char LedgerFileCtx JournalUpdate +ledgerDefaultYear = do + char 'Y' "default year" + many spacenonewline + y <- many1 digit + let y' = read y + failIfInvalidYear y + setYear y' + return $ return id + +-- | Try to parse a ledger entry. If we successfully parse an entry, +-- check it can be balanced, and fail if not. +ledgerTransaction :: GenParser Char LedgerFileCtx Transaction +ledgerTransaction = do + date <- ledgerdate "transaction" + edate <- optionMaybe (ledgereffectivedate date) "effective date" + status <- ledgerstatus "cleared flag" + code <- ledgercode "transaction code" + (description, comment) <- + (do {many1 spacenonewline; d <- liftM rstrip (many (noneOf ";\n")); c <- ledgercomment <|> return ""; newline; return (d, c)} <|> + do {many spacenonewline; c <- ledgercomment <|> return ""; newline; return ("", c)} + ) "description and/or comment" + postings <- ledgerpostings + let t = txnTieKnot $ Transaction date edate status code description comment postings "" + case balanceTransaction t of + Right t' -> return t' + Left err -> fail err + +ledgerdate :: GenParser Char LedgerFileCtx Day +ledgerdate = choice' [ledgerfulldate, ledgerpartialdate] "full or partial date" + +ledgerfulldate :: GenParser Char LedgerFileCtx Day +ledgerfulldate = do + (y,m,d) <- ymd + return $ fromGregorian (read y) (read m) (read d) + +-- | Match a partial M/D date in a ledger, and also require that a default +-- year directive was previously encountered. +ledgerpartialdate :: GenParser Char LedgerFileCtx Day +ledgerpartialdate = do + (_,m,d) <- md + y <- getYear + when (isNothing y) $ fail "partial date found, but no default year specified" + return $ fromGregorian (fromJust y) (read m) (read d) + +ledgerdatetime :: GenParser Char LedgerFileCtx LocalTime +ledgerdatetime = do + day <- ledgerdate + many1 spacenonewline + h <- many1 digit + 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 + +ledgereffectivedate :: Day -> GenParser Char LedgerFileCtx Day +ledgereffectivedate actualdate = do + char '=' + -- kludgy way to use actual date for default year + let withDefaultYear d p = do + y <- getYear + let (y',_,_) = toGregorian d in setYear y' + r <- p + when (isJust y) $ setYear $ fromJust y + return r + edate <- withDefaultYear actualdate ledgerdate + return edate + +ledgerstatus :: GenParser Char st Bool +ledgerstatus = try (do { many1 spacenonewline; char '*' "status"; return True } ) <|> return False + +ledgercode :: GenParser Char st String +ledgercode = try (do { many1 spacenonewline; char '(' "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" + +ledgerpostings :: GenParser Char LedgerFileCtx [Posting] +ledgerpostings = do + -- complicated to handle intermixed comment lines.. please make me better. + ctx <- getState + let parses p = isRight . parseWithCtx ctx p + ls <- many1 $ try linebeginningwithspaces + let ls' = filter (not . (ledgercommentline `parses`)) ls + when (null ls') $ fail "no postings" + return $ map (fromparse . parseWithCtx ctx ledgerposting) ls' + "postings" + +linebeginningwithspaces :: GenParser Char st String +linebeginningwithspaces = do + sp <- many1 spacenonewline + c <- nonspace + cs <- restofline + return $ sp ++ (c:cs) ++ "\n" + +ledgerposting :: GenParser Char LedgerFileCtx Posting +ledgerposting = do + many1 spacenonewline + status <- ledgerstatus + account <- transactionaccountname + let (ptype, account') = (postingTypeFromAccountName account, unbracket account) + amount <- postingamount + many spacenonewline + comment <- ledgercomment <|> return "" + newline + return (Posting status account' amount comment ptype Nothing) + +-- qualify with the parent account from parsing context +transactionaccountname :: GenParser Char LedgerFileCtx AccountName +transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname + +-- | 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 +-- more components of at least one character, separated by the account +-- separator char. +ledgeraccountname :: GenParser Char st AccountName +ledgeraccountname = do + a <- many1 (nonspace <|> singlespace) + let a' = striptrailingspace a + when (accountNameFromComponents (accountNameComponents a') /= a') + (fail $ "accountname seems ill-formed: "++a') + return a' + where + singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}) + -- couldn't avoid consuming a final space sometimes, harmless + striptrailingspace s = if last s == ' ' then init s else s + +-- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace +-- "account name character (non-bracket, non-parenthesis, non-whitespace)" + +-- | Parse an amount, with an optional left or right currency symbol and +-- optional price. +postingamount :: GenParser Char st MixedAmount +postingamount = + try (do + many1 spacenonewline + someamount <|> return missingamt + ) <|> return missingamt + +someamount :: GenParser Char st MixedAmount +someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount + +leftsymbolamount :: GenParser Char st MixedAmount +leftsymbolamount = do + sym <- commoditysymbol + sp <- many spacenonewline + (q,p,comma) <- amountquantity + pri <- priceamount + let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,comma=comma,precision=p} + return $ Mixed [Amount c q pri] + "left-symbol amount" + +rightsymbolamount :: GenParser Char st MixedAmount +rightsymbolamount = do + (q,p,comma) <- amountquantity + sp <- many spacenonewline + sym <- commoditysymbol + pri <- priceamount + let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,comma=comma,precision=p} + return $ Mixed [Amount c q pri] + "right-symbol amount" + +nosymbolamount :: GenParser Char st MixedAmount +nosymbolamount = do + (q,p,comma) <- amountquantity + pri <- priceamount + let c = Commodity {symbol="",side=L,spaced=False,comma=comma,precision=p} + return $ Mixed [Amount c q pri] + "no-symbol amount" + +commoditysymbol :: GenParser Char st String +commoditysymbol = (quotedcommoditysymbol <|> + many1 (noneOf "0123456789-.@;\n \"") + ) "commodity symbol" + +quotedcommoditysymbol :: GenParser Char st String +quotedcommoditysymbol = do + char '"' + s <- many1 $ noneOf "-.@;\n \"" + char '"' + return s + +priceamount :: GenParser Char st (Maybe MixedAmount) +priceamount = + try (do + many spacenonewline + char '@' + many spacenonewline + a <- someamount -- XXX could parse more prices ad infinitum, shouldn't + return $ Just a + ) <|> return Nothing + +-- gawd.. trying to parse a ledger number without error: + +-- | Parse a ledger-style numeric quantity and also return the number of +-- digits to the right of the decimal point and whether thousands are +-- separated by comma. +amountquantity :: GenParser Char st (Double, Int, Bool) +amountquantity = do + sign <- optionMaybe $ string "-" + (intwithcommas,frac) <- numberparts + let comma = ',' `elem` intwithcommas + let precision = length frac + -- read the actual value. We expect this read to never fail. + let int = filter (/= ',') intwithcommas + let int' = if null int then "0" else int + let frac' = if null frac then "0" else frac + let sign' = fromMaybe "" sign + let quantity = read $ sign'++int'++"."++frac' + return (quantity, precision, comma) + "commodity quantity" + +-- | parse the two strings of digits before and after a possible decimal +-- point. The integer part may contain commas, or either part may be +-- empty, or there may be no point. +numberparts :: GenParser Char st (String,String) +numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint + +numberpartsstartingwithdigit :: GenParser Char st (String,String) +numberpartsstartingwithdigit = do + let digitorcomma = digit <|> char ',' + first <- digit + rest <- many digitorcomma + frac <- try (do {char '.'; many digit}) <|> return "" + return (first:rest,frac) + +numberpartsstartingwithpoint :: GenParser Char st (String,String) +numberpartsstartingwithpoint = do + char '.' + frac <- many1 digit + return ("",frac) + + +-- | Parse a timelog entry. +timelogentry :: GenParser Char LedgerFileCtx TimeLogEntry +timelogentry = do + code <- oneOf "bhioO" + many1 spacenonewline + datetime <- ledgerdatetime + comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline) + return $ TimeLogEntry (read [code]) datetime (fromMaybe "" comment) + + +-- | 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 + +compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] + + +tests_Parse = TestList [ + + "ledgerTransaction" ~: do + assertParseEqual (parseWithCtx emptyCtx ledgerTransaction entry1_str) entry1 + assertBool "ledgerTransaction should not parse just a date" + $ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1\n" + assertBool "ledgerTransaction should require some postings" + $ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a\n" + let t = parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a ;comment\n b 1\n" + assertBool "ledgerTransaction should not include a comment in the description" + $ either (const False) ((== "a") . tdescription) t + + ,"ledgerModifierTransaction" ~: do + assertParse (parseWithCtx emptyCtx ledgerModifierTransaction "= (some value expr)\n some:postings 1\n") + + ,"ledgerPeriodicTransaction" ~: do + assertParse (parseWithCtx emptyCtx ledgerPeriodicTransaction "~ (some period expr)\n some:postings 1\n") + + ,"ledgerExclamationDirective" ~: do + assertParse (parseWithCtx emptyCtx ledgerExclamationDirective "!include /some/file.x\n") + assertParse (parseWithCtx emptyCtx ledgerExclamationDirective "!account some:account\n") + assertParse (parseWithCtx emptyCtx (ledgerExclamationDirective >> ledgerExclamationDirective) "!account a\n!end\n") + + ,"ledgercommentline" ~: do + assertParse (parseWithCtx emptyCtx ledgercommentline "; some comment \n") + assertParse (parseWithCtx emptyCtx ledgercommentline " \t; x\n") + assertParse (parseWithCtx emptyCtx ledgercommentline ";x") + + ,"ledgerDefaultYear" ~: do + assertParse (parseWithCtx emptyCtx ledgerDefaultYear "Y 2010\n") + assertParse (parseWithCtx emptyCtx ledgerDefaultYear "Y 10001\n") + + ,"ledgerHistoricalPrice" ~: + assertParseEqual (parseWithCtx emptyCtx ledgerHistoricalPrice "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55]) + + ,"ledgerIgnoredPriceCommodity" ~: do + assertParse (parseWithCtx emptyCtx ledgerIgnoredPriceCommodity "N $\n") + + ,"ledgerDefaultCommodity" ~: do + assertParse (parseWithCtx emptyCtx ledgerDefaultCommodity "D $1,000.0\n") + + ,"ledgerCommodityConversion" ~: do + assertParse (parseWithCtx emptyCtx ledgerCommodityConversion "C 1h = $50.00\n") + + ,"ledgerTagDirective" ~: do + assertParse (parseWithCtx emptyCtx ledgerTagDirective "tag foo \n") + + ,"ledgerEndTagDirective" ~: do + assertParse (parseWithCtx emptyCtx ledgerEndTagDirective "end tag \n") + + ,"ledgeraccountname" ~: do + assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c") + assertBool "ledgeraccountname rejects an empty inner component" (isLeft $ parsewith ledgeraccountname "a::c") + assertBool "ledgeraccountname rejects an empty leading component" (isLeft $ parsewith ledgeraccountname ":b:c") + assertBool "ledgeraccountname rejects an empty trailing component" (isLeft $ parsewith ledgeraccountname "a:b:") + + ,"ledgerposting" ~: do + assertParseEqual (parseWithCtx emptyCtx ledgerposting " expenses:food:dining $10.00\n") + (Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting Nothing) + assertBool "ledgerposting parses a quoted commodity with numbers" + (isRight $ parseWithCtx emptyCtx ledgerposting " a 1 \"DE123\"\n") + + ,"someamount" ~: do + let -- | compare a parse result with a MixedAmount, showing the debug representation for clarity + assertMixedAmountParse parseresult mixedamount = + (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount) + assertMixedAmountParse (parsewith someamount "1 @ $2") + (Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])]) + + ,"postingamount" ~: do + assertParseEqual (parseWithCtx emptyCtx postingamount " $47.18") (Mixed [dollars 47.18]) + assertParseEqual (parseWithCtx emptyCtx postingamount " $1.") + (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing]) + + ] + +entry1_str = unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ," assets:checking $-47.18" + ,"" + ] + +entry1 = + txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing, + Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting Nothing] "" + + diff --git a/Hledger/Data/Posting.hs b/Hledger/Data/Posting.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Posting.hs @@ -0,0 +1,94 @@ +{-| + +A 'Posting' represents a 'MixedAmount' being added to or subtracted from a +single 'Account'. Each 'Transaction' contains two or more postings which +should add up to 0. Postings also reference their parent transaction, so +we can get a date or description for a posting (from the transaction). + +-} + +module Hledger.Data.Posting +where +import Hledger.Data.Utils +import Hledger.Data.Types +import Hledger.Data.Amount +import Hledger.Data.AccountName +import Hledger.Data.Dates (nulldate) + + +instance Show Posting where show = showPosting + +nullposting = Posting False "" nullmixedamt "" RegularPosting Nothing + +showPosting :: Posting -> String +showPosting (Posting{paccount=a,pamount=amt,pcomment=com,ptype=t}) = + concatTopPadded [showaccountname a ++ " ", showamount amt, comment] + where + ledger3ishlayout = False + acctnamewidth = if ledger3ishlayout then 25 else 22 + showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width + (bracket,width) = case t of + BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2) + VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2) + _ -> (id,acctnamewidth) + showamount = padleft 12 . showMixedAmountOrZero + comment = if null com then "" else " ; " ++ com +-- XXX refactor +showPostingForRegister (Posting{paccount=a,pamount=amt,ptype=t}) = + concatTopPadded [showaccountname a ++ " ", showamount amt] + where + ledger3ishlayout = False + acctnamewidth = if ledger3ishlayout then 25 else 22 + showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width + (bracket,width) = case t of + BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2) + VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2) + _ -> (id,acctnamewidth) + showamount = padleft 12 . showMixedAmountOrZeroWithoutPrice + +isReal :: Posting -> Bool +isReal p = ptype p == RegularPosting + +isVirtual :: Posting -> Bool +isVirtual p = ptype p == VirtualPosting + +isBalancedVirtual :: Posting -> Bool +isBalancedVirtual p = ptype p == BalancedVirtualPosting + +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 + +postingDate :: Posting -> Day +postingDate p = maybe nulldate tdate $ ptransaction p + +postingCleared :: Posting -> Bool +postingCleared p = maybe False tstatus $ ptransaction p + +-- | Does this posting fall within the given date span ? +isPostingInDateSpan :: DateSpan -> Posting -> Bool +isPostingInDateSpan (DateSpan Nothing Nothing) _ = True +isPostingInDateSpan (DateSpan Nothing (Just e)) p = postingDate p < e +isPostingInDateSpan (DateSpan (Just b) Nothing) p = postingDate p >= b +isPostingInDateSpan (DateSpan (Just b) (Just e)) p = d >= b && d < e where d = postingDate p + +isEmptyPosting :: Posting -> Bool +isEmptyPosting = isZeroMixedAmount . pamount + +-- | Get the minimal date span which contains all the postings, or +-- DateSpan Nothing Nothing if there are none. +postingsDateSpan :: [Posting] -> DateSpan +postingsDateSpan [] = DateSpan Nothing Nothing +postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps') + where ps' = sortBy (comparing postingDate) ps + diff --git a/Hledger/Data/TimeLog.hs b/Hledger/Data/TimeLog.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/TimeLog.hs @@ -0,0 +1,121 @@ +{-| + +A 'TimeLogEntry' is a clock-in, clock-out, or other directive in a timelog +file (see timeclock.el or the command-line version). These can be +converted to 'Transactions' and queried like a ledger. + +-} + +module Hledger.Data.TimeLog +where +import Data.Time.Format +import System.Locale (defaultTimeLocale) +import Hledger.Data.Utils +import Hledger.Data.Types +import Hledger.Data.Dates +import Hledger.Data.Commodity +import Hledger.Data.Transaction + +instance Show TimeLogEntry where + show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t) + +instance Show TimeLogCode where + show SetBalance = "b" + show SetRequiredHours = "h" + show In = "i" + show Out = "o" + show FinalOut = "O" + +instance Read TimeLogCode where + readsPrec _ ('b' : xs) = [(SetBalance, xs)] + readsPrec _ ('h' : xs) = [(SetRequiredHours, xs)] + readsPrec _ ('i' : xs) = [(In, xs)] + readsPrec _ ('o' : xs) = [(Out, xs)] + readsPrec _ ('O' : xs) = [(FinalOut, xs)] + readsPrec _ _ = [] + +-- | Convert time log entries to ledger transactions. When there is no +-- clockout, add one with the provided current time. Sessions crossing +-- midnight are split into days to give accurate per-day totals. +timeLogEntriesToTransactions :: LocalTime -> [TimeLogEntry] -> [Transaction] +timeLogEntriesToTransactions _ [] = [] +timeLogEntriesToTransactions now [i] + | odate > idate = entryFromTimeLogInOut i o' : timeLogEntriesToTransactions now [i',o] + | otherwise = [entryFromTimeLogInOut i o] + where + o = TimeLogEntry Out end "" + end = if itime > now then itime else now + (itime,otime) = (tldatetime i,tldatetime o) + (idate,odate) = (localDay itime,localDay otime) + o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}} + i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}} +timeLogEntriesToTransactions now (i:o:rest) + | odate > idate = entryFromTimeLogInOut i o' : timeLogEntriesToTransactions now (i':o:rest) + | otherwise = entryFromTimeLogInOut i o : timeLogEntriesToTransactions now rest + where + (itime,otime) = (tldatetime i,tldatetime o) + (idate,odate) = (localDay itime,localDay otime) + o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}} + i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}} + +-- | Convert a timelog clockin and clockout entry to an equivalent ledger +-- entry, representing the time expenditure. Note this entry is not balanced, +-- since we omit the \"assets:time\" transaction for simpler output. +entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Transaction +entryFromTimeLogInOut i o + | otime >= itime = t + | otherwise = + error $ "clock-out time less than clock-in time in:\n" ++ showTransaction t + where + t = Transaction { + tdate = idate, + teffectivedate = Nothing, + tstatus = True, + tcode = "", + tdescription = showtime itod ++ "-" ++ showtime otod, + tcomment = "", + tpostings = ps, + tpreceding_comment_lines="" + } + showtime = take 5 . show + acctname = tlcomment i + itime = tldatetime i + otime = tldatetime o + itod = localTimeOfDay itime + otod = localTimeOfDay otime + idate = localDay itime + hrs = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc + amount = Mixed [hours hrs] + ps = [Posting{pstatus=False,paccount=acctname,pamount=amount, + pcomment="",ptype=VirtualPosting,ptransaction=Just t}] + +tests_TimeLog = TestList [ + + "timeLogEntriesToTransactions" ~: do + today <- getCurrentDay + now' <- getCurrentTime + tz <- getCurrentTimeZone + let now = utcToLocalTime tz now' + nowstr = showtime now + yesterday = prevday today + clockin = TimeLogEntry In + mktime d = LocalTime d . fromMaybe midnight . parseTime defaultTimeLocale "%H:%M:%S" + showtime = formatTime defaultTimeLocale "%H:%M" + assertEntriesGiveStrings name es ss = assertEqual name ss (map tdescription $ timeLogEntriesToTransactions now es) + + assertEntriesGiveStrings "started yesterday, split session at midnight" + [clockin (mktime yesterday "23:00:00") ""] + ["23:00-23:59","00:00-"++nowstr] + assertEntriesGiveStrings "split multi-day sessions at each midnight" + [clockin (mktime (addDays (-2) today) "23:00:00") ""] + ["23:00-23:59","00:00-23:59","00:00-"++nowstr] + assertEntriesGiveStrings "auto-clock-out if needed" + [clockin (mktime today "00:00:00") ""] + ["00:00-"++nowstr] + let future = utcToLocalTime tz $ addUTCTime 100 now' + futurestr = showtime future + assertEntriesGiveStrings "use the clockin time for auto-clockout if it's in the future" + [clockin future ""] + [printf "%s-%s" futurestr futurestr] + + ] diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Transaction.hs @@ -0,0 +1,253 @@ +{-| + +A 'Transaction' represents a single balanced entry in the ledger file. It +normally contains two or more balanced 'Posting's. + +-} + +module Hledger.Data.Transaction +where +import Hledger.Data.Utils +import Hledger.Data.Types +import Hledger.Data.Dates +import Hledger.Data.Posting +import Hledger.Data.Amount +import Hledger.Data.Commodity (dollars, dollar, unknown) + +instance Show Transaction where show = showTransactionUnelided + +instance Show ModifierTransaction where + show t = "= " ++ mtvalueexpr t ++ "\n" ++ unlines (map show (mtpostings t)) + +instance Show PeriodicTransaction where + show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t)) + +nulltransaction :: Transaction +nulltransaction = Transaction { + tdate=nulldate, + teffectivedate=Nothing, + tstatus=False, + tcode="", + tdescription="", + tcomment="", + tpostings=[], + tpreceding_comment_lines="" + } + +{-| +Show a ledger entry, formatted for the print command. ledger 2.x's +standard format looks like this: + +@ +yyyy/mm/dd[ *][ CODE] description......... [ ; comment...............] + account name 1..................... ...$amount1[ ; comment...............] + account name 2..................... ..$-amount1[ ; comment...............] + +pcodewidth = no limit -- 10 -- mimicking ledger layout. +pdescwidth = no limit -- 20 -- I don't remember what these mean, +pacctwidth = 35 minimum, no maximum -- they were important at the time. +pamtwidth = 11 +pcommentwidth = no limit -- 22 +@ +-} +showTransaction :: Transaction -> String +showTransaction = showTransaction' True False + +showTransactionUnelided :: Transaction -> String +showTransactionUnelided = showTransaction' False False + +showTransactionForPrint :: Bool -> Transaction -> String +showTransactionForPrint effective = showTransaction' False effective + +showTransaction' :: Bool -> Bool -> Transaction -> String +showTransaction' elide effective t = + unlines $ [description] ++ showpostings (tpostings t) ++ [""] + where + description = concat [date, status, code, desc, comment] + date | effective = showdate $ fromMaybe (tdate t) $ teffectivedate t + | otherwise = showdate (tdate t) ++ maybe "" showedate (teffectivedate t) + status = if tstatus t then " *" else "" + code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else "" + desc = ' ' : tdescription t + comment = if null com then "" else " ; " ++ com where com = tcomment t + showdate = printf "%-10s" . showDate + showedate = printf "=%s" . showdate + showpostings ps + | elide && length ps > 1 && isTransactionBalanced t + = map showposting (init ps) ++ [showpostingnoamt (last ps)] + | otherwise = map showposting ps + where + showposting p = showacct p ++ " " ++ showamount (pamount p) ++ showcomment (pcomment p) + showpostingnoamt p = rstrip $ showacct p ++ " " ++ showcomment (pcomment p) + showacct p = " " ++ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p)) + w = maximum $ map (length . paccount) ps + showamount = printf "%12s" . showMixedAmountOrZero + showcomment s = if null s then "" else " ; "++s + showstatus p = if pstatus p then "* " else "" + +-- | Show an account name, clipped to the given width if any, and +-- appropriately bracketed/parenthesised for the given posting type. +showAccountName :: Maybe Int -> PostingType -> AccountName -> String +showAccountName w = fmt + where + fmt RegularPosting = take w' + fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse + fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse + w' = fromMaybe 999999 w + parenthesise s = "("++s++")" + bracket s = "["++s++"]" + +realPostings :: Transaction -> [Posting] +realPostings = filter isReal . tpostings + +virtualPostings :: Transaction -> [Posting] +virtualPostings = filter isVirtual . tpostings + +balancedVirtualPostings :: Transaction -> [Posting] +balancedVirtualPostings = filter isBalancedVirtual . tpostings + +-- | Get the sums of a transaction's real, virtual, and balanced virtual postings. +transactionPostingBalances :: Transaction -> (MixedAmount,MixedAmount,MixedAmount) +transactionPostingBalances t = (sumPostings $ realPostings t + ,sumPostings $ virtualPostings t + ,sumPostings $ balancedVirtualPostings t) + +-- | Is this transaction balanced ? A balanced transaction's real +-- (non-virtual) postings sum to 0, and any balanced virtual postings +-- also sum to 0. +isTransactionBalanced :: Transaction -> Bool +isTransactionBalanced t = isReallyZeroMixedAmountCost rsum && isReallyZeroMixedAmountCost bvsum + where (rsum, _, bvsum) = transactionPostingBalances t + +-- | Ensure that this entry is balanced, possibly auto-filling a missing +-- amount first. We can auto-fill if there is just one non-virtual +-- transaction without an amount. The auto-filled balance will be +-- converted to cost basis if possible. If the entry can not be balanced, +-- return an error message instead. +balanceTransaction :: Transaction -> Either String Transaction +balanceTransaction t@Transaction{tpostings=ps} + | length rwithoutamounts > 1 || length bvwithoutamounts > 1 + = Left $ printerr "could not balance this transaction (too many missing amounts)" + | not $ isTransactionBalanced t' = Left $ printerr $ nonzerobalanceerror t' + | otherwise = Right t' + where + rps = filter isReal ps + bvps = filter isBalancedVirtual ps + (rwithamounts, rwithoutamounts) = partition hasAmount rps + (bvwithamounts, bvwithoutamounts) = partition hasAmount bvps + t' = t{tpostings=map balance ps} + where + balance p | not (hasAmount p) && isReal p + = p{pamount = costOfMixedAmount (-(sum $ map pamount rwithamounts))} + | not (hasAmount p) && isBalancedVirtual p + = p{pamount = costOfMixedAmount (-(sum $ map pamount bvwithamounts))} + | otherwise = p + printerr s = intercalate "\n" [s, showTransactionUnelided t] + +nonzerobalanceerror :: Transaction -> String +nonzerobalanceerror t = printf "could not balance this transaction (%s%s%s)" rmsg sep bvmsg + where + (rsum, _, bvsum) = transactionPostingBalances t + rmsg | isReallyZeroMixedAmountCost rsum = "" + | otherwise = "real postings are off by " ++ show rsum + bvmsg | isReallyZeroMixedAmountCost bvsum = "" + | otherwise = "balanced virtual postings are off by " ++ show bvsum + sep = if not (null rmsg) && not (null bvmsg) then "; " else "" + +-- | Convert the primary date to either the actual or effective date. +ledgerTransactionWithDate :: WhichDate -> Transaction -> Transaction +ledgerTransactionWithDate ActualDate t = t +ledgerTransactionWithDate EffectiveDate t = txnTieKnot t{tdate=fromMaybe (tdate t) (teffectivedate t)} + + +-- | Ensure a transaction's postings refer back to it. +txnTieKnot :: Transaction -> Transaction +txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (settxn t) ps} + +-- | Set a posting's parent transaction. +settxn :: Transaction -> Posting -> Posting +settxn t p = p{ptransaction=Just t} + +tests_Transaction = TestList [ + "showTransaction" ~: do + assertEqual "show a balanced transaction, eliding last amount" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ," assets:checking" + ,"" + ]) + (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting (Just t) + ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting (Just t) + ] "" + in showTransaction t) + + ,"showTransaction" ~: do + assertEqual "show a balanced transaction, no eliding" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ," assets:checking $-47.18" + ,"" + ]) + (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting (Just t) + ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting (Just t) + ] "" + in showTransactionUnelided t) + + -- document some cases that arise in debug/testing: + ,"showTransaction" ~: do + assertEqual "show an unbalanced transaction, should not elide" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ," assets:checking $-47.19" + ,"" + ]) + (showTransaction + (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing + ,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting Nothing + ] "")) + + ,"showTransaction" ~: do + assertEqual "show an unbalanced transaction with one posting, should not elide" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ,"" + ]) + (showTransaction + (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing + ] "")) + + ,"showTransaction" ~: do + assertEqual "show a transaction with one posting and a missing amount" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries " + ,"" + ]) + (showTransaction + (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" missingamt "" RegularPosting Nothing + ] "")) + + ,"showTransaction" ~: do + assertEqual "show a transaction with a priced commodityless amount" + (unlines + ["2010/01/01 x" + ," a 1 @ $2" + ," b " + ,"" + ]) + (showTransaction + (txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" + [Posting False "a" (Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])]) "" RegularPosting Nothing + ,Posting False "b" missingamt "" RegularPosting Nothing + ] "")) + + ] diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Types.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-| + +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. +> [HistoricalPrice] -- historical commodity prices +> +> Ledger -- a ledger is derived from a journal, by applying a filter specification. 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 + +For more detailed documentation on each type, see the corresponding modules. + +Evolution of transaction/entry/posting terminology: + + - ledger 2: entries contain transactions + + - hledger 0.4: Entrys contain RawTransactions (which are flattened to Transactions) + + - ledger 3: transactions contain postings + + - hledger 0.5: LedgerTransactions contain Postings (which are flattened to Transactions) + + - hledger 0.8: Transactions contain Postings (referencing Transactions, corecursively) + + - hledger 0.10: Postings should be called Entrys, but are left as-is for now + +-} + +module Hledger.Data.Types +where +import Hledger.Data.Utils +import qualified Data.Map as Map +import System.Time (ClockTime) +import Data.Typeable (Typeable) + + +type SmartDate = (String,String,String) + +data WhichDate = ActualDate | EffectiveDate deriving (Eq,Show) + +data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord) + +data Interval = NoInterval | Daily | Weekly | Monthly | Quarterly | Yearly + deriving (Eq,Show,Ord) + +type AccountName = String + +data Side = L | R deriving (Eq,Show,Ord) + +data Commodity = Commodity { + symbol :: String, -- ^ the commodity's symbol + -- display preferences for amounts of this commodity + side :: Side, -- ^ should the symbol appear on the left or the right + spaced :: Bool, -- ^ should there be a space between symbol and quantity + comma :: Bool, -- ^ should thousands be comma-separated + precision :: Int -- ^ number of decimal places to display + } deriving (Eq,Show,Ord) + +data Amount = Amount { + commodity :: Commodity, + quantity :: Double, + price :: Maybe MixedAmount -- ^ unit price/conversion rate for this amount at posting time + } deriving (Eq) + +newtype MixedAmount = Mixed [Amount] deriving (Eq) + +data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting + deriving (Eq,Show) + +data Posting = Posting { + pstatus :: Bool, + paccount :: AccountName, + pamount :: MixedAmount, + pcomment :: String, + ptype :: PostingType, + ptransaction :: Maybe Transaction -- ^ this posting's parent transaction (co-recursive types). + -- Tying this knot gets tedious, Maybe makes it easier/optional. + } + +-- The equality test for postings ignores the parent transaction's +-- identity, to avoid infinite loops. +instance Eq Posting where + (==) (Posting a1 b1 c1 d1 e1 _) (Posting a2 b2 c2 d2 e2 _) = a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 + +data Transaction = Transaction { + tdate :: Day, + teffectivedate :: Maybe Day, + tstatus :: Bool, -- XXX tcleared ? + tcode :: String, + tdescription :: String, + tcomment :: String, + tpostings :: [Posting], -- ^ this transaction's postings (co-recursive types). + tpreceding_comment_lines :: String + } deriving (Eq) + +data ModifierTransaction = ModifierTransaction { + mtvalueexpr :: String, + mtpostings :: [Posting] + } deriving (Eq) + +data PeriodicTransaction = PeriodicTransaction { + ptperiodicexpr :: String, + ptpostings :: [Posting] + } deriving (Eq) + +data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord) + +data TimeLogEntry = TimeLogEntry { + tlcode :: TimeLogCode, + tldatetime :: LocalTime, + tlcomment :: String + } deriving (Eq,Ord) + +data HistoricalPrice = HistoricalPrice { + hdate :: Day, + hsymbol :: String, + hamount :: MixedAmount + } deriving (Eq) -- & Show (in Amount.hs) + +data Journal = Journal { + jmodifiertxns :: [ModifierTransaction], + jperiodictxns :: [PeriodicTransaction], + jtxns :: [Transaction], + open_timelog_entries :: [TimeLogEntry], + historical_prices :: [HistoricalPrice], + final_comment_lines :: String, + filepath :: FilePath, + filereadtime :: ClockTime, + jtext :: String + } deriving (Eq, Typeable) + +data Ledger = Ledger { + journal :: Journal, + accountnametree :: Tree AccountName, + accountmap :: Map.Map AccountName Account + } + +data Account = Account { + aname :: AccountName, + apostings :: [Posting], -- ^ postings in this account + abalance :: MixedAmount -- ^ sum of postings in this account and subaccounts + } + +-- | A generic, pure specification of how to filter 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/Utils.hs b/Hledger/Data/Utils.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/Utils.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE CPP #-} +{-| + +Provide standard imports and utilities which are useful everywhere, or +needed low in the module hierarchy. This is the bottom of the dependency 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 Text.Printf, +module Text.RegexPR, +module Test.HUnit, +) +where +import Data.Char +import Control.Exception +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 +#if __GLASGOW_HASKELL__ <= 610 +import Prelude hiding (readFile,putStr,print) +import System.IO.UTF8 +#endif +import Test.HUnit +import Text.Printf +import Text.RegexPR +import Text.ParserCombinators.Parsec + + +-- 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 ' ' + +-- 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 newline and a label prepended +ltrace :: Show a => String -> a -> a +ltrace l a = trace (l ++ ": " ++ show a) a + +-- | trace an expression using a custom show function +tracewith f e = trace (f e) e + +-- parsing + +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 + +strictReadFile :: FilePath -> IO String +strictReadFile f = readFile f >>= \s -> Control.Exception.evaluate (length s) >> return s diff --git a/Ledger.hs b/Ledger.hs deleted file mode 100644 --- a/Ledger.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-| - -The Ledger library allows parsing and querying of ledger files. It -generally provides a compatible subset of C++ ledger's functionality. -This package re-exports all the Ledger.* modules. - --} - -module Ledger ( - module Ledger.Account, - module Ledger.AccountName, - module Ledger.Amount, - module Ledger.Commodity, - module Ledger.Dates, - module Ledger.IO, - module Ledger.Transaction, - module Ledger.Ledger, - module Ledger.Parse, - module Ledger.Journal, - module Ledger.Posting, - module Ledger.TimeLog, - module Ledger.Types, - module Ledger.Utils, - tests_Ledger - ) -where -import Ledger.Account -import Ledger.AccountName -import Ledger.Amount -import Ledger.Commodity -import Ledger.Dates -import Ledger.IO -import Ledger.Transaction -import Ledger.Ledger -import Ledger.Parse -import Ledger.Journal -import Ledger.Posting -import Ledger.TimeLog -import Ledger.Types -import Ledger.Utils - -tests_Ledger = TestList - [ - -- Ledger.Account.tests_Account - -- ,Ledger.AccountName.tests_AccountName - Ledger.Amount.tests_Amount - -- ,Ledger.Commodity.tests_Commodity - ,Ledger.Dates.tests_Dates - -- ,Ledger.IO.tests_IO - ,Ledger.Transaction.tests_Transaction - -- ,Ledger.Ledger.tests_Ledger - ,Ledger.Parse.tests_Parse - -- ,Ledger.Journal.tests_Journal - -- ,Ledger.Posting.tests_Posting - -- ,Ledger.TimeLog.tests_TimeLog - -- ,Ledger.Types.tests_Types - -- ,Ledger.Utils.tests_Utils - ] diff --git a/Ledger/Account.hs b/Ledger/Account.hs deleted file mode 100644 --- a/Ledger/Account.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-| - -A compound data type for efficiency. An 'Account' stores - -- an 'AccountName', - -- all 'Posting's in the account, excluding subaccounts - -- a 'MixedAmount' representing the account balance, including subaccounts. - --} - -module Ledger.Account -where -import Ledger.Utils -import Ledger.Types -import Ledger.Amount - - -instance Show Account where - show (Account a ts b) = printf "Account %s with %d txns and %s balance" a (length ts) (showMixedAmount b) - -instance Eq Account where - (==) (Account n1 t1 b1) (Account n2 t2 b2) = n1 == n2 && t1 == t2 && b1 == b2 - -nullacct = Account "" [] nullmixedamt - diff --git a/Ledger/AccountName.hs b/Ledger/AccountName.hs deleted file mode 100644 --- a/Ledger/AccountName.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction#-} -{-| - -'AccountName's are strings like @assets:cash:petty@. -From a set of these we derive the account hierarchy. - --} - -module Ledger.AccountName -where -import Ledger.Utils -import Ledger.Types -import Data.Map (Map) -import qualified Data.Map as M - - - --- change to use a different separator for nested accounts -acctsepchar = ':' - -accountNameComponents :: AccountName -> [String] -accountNameComponents = splitAtElement acctsepchar - -accountNameFromComponents :: [String] -> AccountName -accountNameFromComponents = concat . intersperse [acctsepchar] - -accountLeafName :: AccountName -> String -accountLeafName = last . accountNameComponents - -accountNameLevel :: AccountName -> Int -accountNameLevel "" = 0 -accountNameLevel a = length (filter (==acctsepchar) a) + 1 - --- | ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"] -expandAccountNames :: [AccountName] -> [AccountName] -expandAccountNames as = nub $ concatMap expand as - where expand = map accountNameFromComponents . tail . inits . accountNameComponents - --- | ["a:b:c","d:e"] -> ["a","d"] -topAccountNames :: [AccountName] -> [AccountName] -topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1] - -parentAccountName :: AccountName -> AccountName -parentAccountName = accountNameFromComponents . init . accountNameComponents - -parentAccountNames :: AccountName -> [AccountName] -parentAccountNames a = parentAccountNames' $ parentAccountName a - where - parentAccountNames' "" = [] - parentAccountNames' a = a : parentAccountNames' (parentAccountName a) - -isAccountNamePrefixOf :: AccountName -> AccountName -> Bool -isAccountNamePrefixOf = isPrefixOf . (++ [acctsepchar]) - -isSubAccountNameOf :: AccountName -> AccountName -> Bool -s `isSubAccountNameOf` p = - (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1)) - --- | From a list of account names, select those which are direct --- subaccounts of the given account name. -subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName] -subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts - --- | Convert a list of account names to a tree. -accountNameTreeFrom :: [AccountName] -> Tree AccountName -accountNameTreeFrom = accountNameTreeFrom1 - -accountNameTreeFrom1 accts = - Node "top" (accounttreesfrom (topAccountNames accts)) - where - accounttreesfrom :: [AccountName] -> [Tree AccountName] - accounttreesfrom [] = [] - accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as] - subs = subAccountNamesFrom (expandAccountNames accts) - -nullaccountnametree = Node "top" [] - -accountNameTreeFrom2 accts = - Node "top" $ unfoldForest (\a -> (a, subs a)) $ topAccountNames accts - where - subs = subAccountNamesFrom allaccts - allaccts = expandAccountNames accts - -- subs' a = subsmap ! a - -- subsmap :: Map AccountName [AccountName] - -- subsmap = Data.Map.fromList [(a, subAccountNamesFrom allaccts a) | a <- allaccts] - -accountNameTreeFrom3 accts = - Node "top" $ forestfrom allaccts $ topAccountNames accts - where - -- drop accts from the list of potential subs as we add them to the tree - forestfrom :: [AccountName] -> [AccountName] -> Forest AccountName - forestfrom subaccts accts = - [let subaccts' = subaccts \\ accts in Node a $ forestfrom subaccts' (subAccountNamesFrom subaccts' a) | a <- accts] - allaccts = expandAccountNames accts - - --- a more efficient tree builder from Cale Gibbard -newtype Tree' a = T (Map a (Tree' a)) - deriving (Show, Eq, Ord) - -mergeTrees :: (Ord a) => Tree' a -> Tree' a -> Tree' a -mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m') - -emptyTree = T M.empty - -pathtree :: [a] -> Tree' a -pathtree [] = T M.empty -pathtree (x:xs) = T (M.singleton x (pathtree xs)) - -fromPaths :: (Ord a) => [[a]] -> Tree' a -fromPaths = foldl' mergeTrees emptyTree . map pathtree - --- the above, but trying to build Tree directly - --- mergeTrees' :: (Ord a) => Tree a -> Tree a -> Tree a --- mergeTrees' (Node m ms) (Node m' ms') = Node undefined (ms `union` ms') - --- emptyTree' = Node "top" [] - --- pathtree' :: [a] -> Tree a --- pathtree' [] = Node undefined [] --- pathtree' (x:xs) = Node x [pathtree' xs] - --- fromPaths' :: (Ord a) => [[a]] -> Tree a --- fromPaths' = foldl' mergeTrees' emptyTree' . map pathtree' - - --- converttree :: [AccountName] -> Tree' AccountName -> [Tree AccountName] --- converttree parents (T m) = [Node (accountNameFromComponents $ parents ++ [a]) (converttree (parents++[a]) b) | (a,b) <- M.toList m] - --- accountNameTreeFrom4 :: [AccountName] -> Tree AccountName --- accountNameTreeFrom4 accts = Node "top" (converttree [] $ fromPaths $ map accountNameComponents accts) - -converttree :: Tree' AccountName -> [Tree AccountName] -converttree (T m) = [Node a (converttree b) | (a,b) <- M.toList m] - -expandTreeNames :: Tree AccountName -> Tree AccountName -expandTreeNames (Node x ts) = Node x (map (treemap (\n -> accountNameFromComponents [x,n]) . expandTreeNames) ts) - -accountNameTreeFrom4 :: [AccountName] -> Tree AccountName -accountNameTreeFrom4 = Node "top" . map expandTreeNames . converttree . fromPaths . map accountNameComponents - - --- | Elide an account name to fit in the specified width. --- From the ledger 2.6 news: --- --- @ --- What Ledger now does is that if an account name is too long, it will --- start abbreviating the first parts of the account name down to two --- letters in length. If this results in a string that is still too --- long, the front will be elided -- not the end. For example: --- --- Expenses:Cash ; OK, not too long --- Ex:Wednesday:Cash ; "Expenses" was abbreviated to fit --- Ex:We:Afternoon:Cash ; "Expenses" and "Wednesday" abbreviated --- ; Expenses:Wednesday:Afternoon:Lunch:Snack:Candy:Chocolate:Cash --- ..:Af:Lu:Sn:Ca:Ch:Cash ; Abbreviated and elided! --- @ -elideAccountName :: Int -> AccountName -> AccountName -elideAccountName width s = - elideLeft width $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s - where - elideparts :: Int -> [String] -> [String] -> [String] - elideparts width done ss - | length (accountNameFromComponents $ done++ss) <= width = done++ss - | length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss) - | otherwise = done++ss - -clipAccountName :: Int -> AccountName -> AccountName -clipAccountName n = accountNameFromComponents . take n . accountNameComponents - diff --git a/Ledger/Amount.hs b/Ledger/Amount.hs deleted file mode 100644 --- a/Ledger/Amount.hs +++ /dev/null @@ -1,340 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-| -An 'Amount' is some quantity of money, shares, or anything else. - -A simple amount is a 'Commodity', quantity pair: - -@ - $1 - £-50 - EUR 3.44 - GOOG 500 - 1.5h - 90 apples - 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 \@: - -@ - EUR 3 \@ $1.35 -@ - -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.): - -@ - $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. - --} - -module Ledger.Amount -where -import Ledger.Utils -import Ledger.Types -import Ledger.Commodity - - -instance Show Amount where show = showAmount -instance Show MixedAmount where show = showMixedAmount -deriving instance Show HistoricalPrice - -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 - (+) = amountop (+) - (-) = amountop (-) - (*) = amountop (*) - -instance Ord Amount where - compare (Amount ac aq ap) (Amount bc bq bp) = compare (ac,aq,ap) (bc,bq,bp) - -instance Num MixedAmount where - fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing] - negate (Mixed as) = Mixed $ map negateAmountPreservingPrice 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" - -instance Ord MixedAmount where - compare (Mixed as) (Mixed bs) = compare as bs - -negateAmountPreservingPrice a = (-a){price=price a} - --- | Apply a binary arithmetic operator to two amounts, converting to the --- second one's commodity (and display precision), discarding any price --- information. (Using the second commodity is best since sum and other --- folds start with a no-commodity amount.) -amountop :: (Double -> Double -> Double) -> Amount -> Amount -> Amount -amountop op a@(Amount _ _ _) (Amount bc bq _) = - Amount bc (quantity (convertAmountTo bc a) `op` bq) Nothing - --- | Convert an amount to the specified commodity using the appropriate --- exchange rate (which is currently always 1). -convertAmountTo :: Commodity -> Amount -> Amount -convertAmountTo c2 (Amount c1 q _) = Amount c2 (q * conversionRate c1 c2) Nothing - --- | Convert mixed amount to the specified commodity -convertMixedAmountTo :: Commodity -> MixedAmount -> Amount -convertMixedAmountTo c2 (Mixed ams) = Amount c2 total Nothing - where - total = sum . map (quantity . convertAmountTo c2) $ ams - --- | Convert an amount to the commodity of its saved price, if any. -costOfAmount :: Amount -> Amount -costOfAmount a@(Amount _ _ Nothing) = a -costOfAmount (Amount _ q (Just price)) - | isZeroMixedAmount price = nullamt - | otherwise = Amount pc (pq*q) Nothing - where (Amount pc pq _) = head $ amounts price - --- | Get the string representation of an amount, based on its commodity's --- display settings. -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) = - case side of - L -> printf "%s%s%s%s" sym space quantity price - R -> printf "%s%s%s%s" quantity space sym price - where - space = if spaced then " " else "" - quantity = showAmount' a - price = case pri of (Just pamt) -> " @ " ++ showMixedAmount pamt - Nothing -> "" - --- 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}" - (show c) (show q) (maybe "" showMixedAmountDebug pri) - --- | Get the string representation of an amount, without any \@ price. -showAmountWithoutPrice :: Amount -> String -showAmountWithoutPrice a = showAmount a{price=Nothing} - --- | Get the string representation (of the number part of) of an amount -showAmount' :: Amount -> String -showAmount' (Amount (Commodity {comma=comma,precision=p}) q _) = quantity - where - quantity = commad $ printf ("%."++show p++"f") q - commad = if comma then punctuatethousands else id - --- | 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) - --- | Does this amount appear to be zero when displayed with its given precision ? -isZeroAmount :: Amount -> Bool -isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPrice - --- | 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 "%.10f" . quantity - --- | Access a mixed amount's components. -amounts :: MixedAmount -> [Amount] -amounts (Mixed as) = as - --- | Does this mixed amount appear to be zero - empty, or --- containing only simple amounts which appear to be zero ? -isZeroMixedAmount :: MixedAmount -> Bool -isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmount - --- | Is this mixed amount "really" zero ? See isReallyZeroAmount. -isReallyZeroMixedAmount :: MixedAmount -> Bool -isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmount - --- | 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. -mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool -mixedAmountEquals a b = amounts a' == amounts b' || (isZeroMixedAmount a' && isZeroMixedAmount b') - where a' = normaliseMixedAmount a - b' = normaliseMixedAmount b - --- | Get the string representation of a mixed amount, showing each of --- its component amounts. NB a mixed amount can have an empty amounts --- list in which case it shows as \"\". -showMixedAmount :: MixedAmount -> String -showMixedAmount m = vConcatRightAligned $ map show $ amounts $ normaliseMixedAmount m - --- | Get an unambiguous string representation of a mixed amount for debugging. -showMixedAmountDebug :: MixedAmount -> String -showMixedAmountDebug m = printf "Mixed [%s]" as - where as = intercalate "\n " $ map showAmountDebug $ amounts $ normaliseMixedAmount m - --- | Get the string representation of a mixed amount, but without --- any \@ prices. -showMixedAmountWithoutPrice :: MixedAmount -> String -showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth as - where - (Mixed as) = normaliseMixedAmountIgnoringPrice m - 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 combining any component amounts which have --- the same commodity and the same price. Also removes zero amounts, --- or adds a single zero amount if there are no amounts at all. -normaliseMixedAmount :: MixedAmount -> MixedAmount -normaliseMixedAmount (Mixed as) = Mixed as'' - where - as'' = map sumSamePricedAmountsPreservingPrice $ 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 - --- 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 (convertAmountTo 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 - --- | 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 Commodity {symbol="AUTO",side=L,spaced=False,comma=False,precision=0} 0 Nothing] - - -tests_Amount = TestList [ - - "showMixedAmount" ~: do - showMixedAmount (Mixed [Amount dollar 0 Nothing]) `is` "$0.00" - showMixedAmount (Mixed []) `is` "0" - showMixedAmount missingamt `is` "" - - ,"showMixedAmountOrZero" ~: do - showMixedAmountOrZero (Mixed [Amount dollar 0 Nothing]) `is` "0" - showMixedAmountOrZero (Mixed []) `is` "0" - showMixedAmountOrZero missingamt `is` "" - - ,"amount arithmetic" ~: do - let a1 = dollars 1.23 - let a2 = Amount (comm "$") (-1.23) Nothing - let a3 = Amount (comm "$") (-1.23) Nothing - (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 - 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) - - ,"mixed amount arithmetic" ~: do - let dollar0 = dollar{precision=0} - (sum $ map (Mixed . (\a -> [a])) - [Amount dollar 1.25 Nothing, - Amount dollar0 (-1) Nothing, - Amount dollar (-0.25) Nothing]) - `is` Mixed [Amount dollar 0 Nothing] - - - ] diff --git a/Ledger/Commodity.hs b/Ledger/Commodity.hs deleted file mode 100644 --- a/Ledger/Commodity.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-| - -A 'Commodity' is a symbol representing a currency or some other kind of -thing we are tracking, and some display preferences that tell how to -display 'Amount's of the commodity - is the symbol on the left or right, -are thousands separated by comma, significant decimal places and so on. - --} -module Ledger.Commodity -where -import Ledger.Utils -import Ledger.Types - - --- convenient amount and commodity constructors, for tests etc. - -unknown = Commodity {symbol="", side=L,spaced=False,comma=False,precision=0} -dollar = Commodity {symbol="$", side=L,spaced=False,comma=False,precision=2} -euro = Commodity {symbol="EUR",side=L,spaced=False,comma=False,precision=2} -pound = Commodity {symbol="£", side=L,spaced=False,comma=False,precision=2} -hour = Commodity {symbol="h", side=R,spaced=False,comma=False,precision=1} - -dollars n = Amount dollar n Nothing -euros n = Amount euro n Nothing -pounds n = Amount pound n Nothing -hours n = Amount hour n Nothing - -defaultcommodities = [dollar, euro, pound, hour, unknown] - --- | Look up one of the hard-coded default commodities. For use in tests. -comm :: String -> Commodity -comm sym = fromMaybe - (error "commodity lookup failed") - $ find (\(Commodity{symbol=s}) -> s==sym) defaultcommodities - --- | Find the conversion rate between two commodities. Currently returns 1. -conversionRate :: Commodity -> Commodity -> Double -conversionRate _ _ = 1 - diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs deleted file mode 100644 --- a/Ledger/Dates.hs +++ /dev/null @@ -1,464 +0,0 @@ -{-| - -Date parsing and utilities for hledger. - -For date and time values, we use the standard Day and UTCTime types. - -A 'SmartDate' is a date which may be partially-specified or relative. -Eg 2008\/12\/31, but also 2008\/12, 12\/31, tomorrow, last week, next year. -We represent these as a triple of strings like (\"2008\",\"12\",\"\"), -(\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\"). - -A 'DateSpan' is the span of time between two specific calendar dates, or -an open-ended span where one or both dates are unspecified. (A date span -with both ends unspecified matches all dates.) - -An 'Interval' is ledger's "reporting interval" - weekly, monthly, -quarterly, etc. - --} - -module Ledger.Dates -where - -import Data.Time.Format -import Data.Time.Calendar.OrdinalDate -import System.Locale (defaultTimeLocale) -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Char -import Text.ParserCombinators.Parsec.Combinator -import Ledger.Types -import Ledger.Utils - - -showDate :: Day -> String -showDate = formatTime defaultTimeLocale "%C%y/%m/%d" - -getCurrentDay :: IO Day -getCurrentDay = do - t <- getZonedTime - return $ localDay (zonedTimeToLocalTime t) - -elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a -elapsedSeconds t1 = realToFrac . diffUTCTime t1 - --- | Split a DateSpan into one or more consecutive spans at the specified interval. -splitSpan :: Interval -> DateSpan -> [DateSpan] -splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] -splitSpan NoInterval s = [s] -splitSpan Daily s = splitspan startofday nextday s -splitSpan Weekly s = splitspan startofweek nextweek s -splitSpan Monthly s = splitspan startofmonth nextmonth s -splitSpan Quarterly s = splitspan startofquarter nextquarter s -splitSpan Yearly s = splitspan startofyear nextyear s - -splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan] -splitspan _ _ (DateSpan Nothing Nothing) = [] -splitspan start next (DateSpan Nothing (Just e)) = [DateSpan (Just $ start e) (Just $ next $ start e)] -splitspan start next (DateSpan (Just b) Nothing) = [DateSpan (Just $ start b) (Just $ next $ start b)] -splitspan start next span@(DateSpan (Just b) (Just e)) - | b == e = [span] - | otherwise = splitspan' start next span - where - splitspan' start next (DateSpan (Just b) (Just e)) - | b >= e = [] - | otherwise = DateSpan (Just s) (Just n) - : splitspan' start next (DateSpan (Just n) (Just e)) - where s = start b - n = next s - splitspan' _ _ _ = error "won't happen, avoids warnings" - --- | Count the days in a DateSpan, or if it is open-ended return Nothing. -daysInSpan :: DateSpan -> Maybe Integer -daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays d2 d1 -daysInSpan _ = Nothing - --- | Parse a period expression to an Interval and overall DateSpan using --- the provided reference date, or raise an error. -parsePeriodExpr :: Day -> String -> (Interval, DateSpan) -parsePeriodExpr refdate expr = (interval,span) - where (interval,span) = fromparse $ parsewith (periodexpr refdate) expr - --- | Convert a single smart date string to a date span using the provided --- reference date, or raise an error. -spanFromSmartDateString :: Day -> String -> DateSpan -spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate - where - sdate = fromparse $ parsewith smartdateonly s - -spanFromSmartDate :: Day -> SmartDate -> DateSpan -spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e) - where - (ry,rm,_) = toGregorian refdate - (b,e) = span sdate - span :: SmartDate -> (Day,Day) - span ("","","today") = (refdate, nextday refdate) - span ("","this","day") = (refdate, nextday refdate) - span ("","","yesterday") = (prevday refdate, refdate) - span ("","last","day") = (prevday refdate, refdate) - span ("","","tomorrow") = (nextday refdate, addDays 2 refdate) - span ("","next","day") = (nextday refdate, addDays 2 refdate) - span ("","last","week") = (prevweek refdate, thisweek refdate) - span ("","this","week") = (thisweek refdate, nextweek refdate) - span ("","next","week") = (nextweek refdate, startofweek $ addDays 14 refdate) - span ("","last","month") = (prevmonth refdate, thismonth refdate) - span ("","this","month") = (thismonth refdate, nextmonth refdate) - span ("","next","month") = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate) - span ("","last","quarter") = (prevquarter refdate, thisquarter refdate) - span ("","this","quarter") = (thisquarter refdate, nextquarter refdate) - span ("","next","quarter") = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate) - span ("","last","year") = (prevyear refdate, thisyear refdate) - span ("","this","year") = (thisyear refdate, nextyear refdate) - span ("","next","year") = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate) - span ("","",d) = (day, nextday day) where day = fromGregorian ry rm (read d) - span ("",m,"") = (startofmonth day, nextmonth day) where day = fromGregorian ry (read m) 1 - span ("",m,d) = (day, nextday day) where day = fromGregorian ry (read m) (read d) - span (y,"","") = (startofyear day, nextyear day) where day = fromGregorian (read y) 1 1 - span (y,m,"") = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1 - span (y,m,d) = (day, nextday day) where day = fromGregorian (read y) (read m) (read d) - -showDay :: Day -> String -showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day - --- | 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 - --- | 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 - --- | Convert a SmartDate to an absolute date using the provided reference date. -fixSmartDate :: Day -> SmartDate -> Day -fixSmartDate refdate sdate = fix sdate - where - fix :: SmartDate -> Day - fix ("","","today") = fromGregorian ry rm rd - fix ("","this","day") = fromGregorian ry rm rd - fix ("","","yesterday") = prevday refdate - fix ("","last","day") = prevday refdate - fix ("","","tomorrow") = nextday refdate - fix ("","next","day") = nextday refdate - fix ("","last","week") = prevweek refdate - fix ("","this","week") = thisweek refdate - fix ("","next","week") = nextweek refdate - fix ("","last","month") = prevmonth refdate - fix ("","this","month") = thismonth refdate - fix ("","next","month") = nextmonth refdate - fix ("","last","quarter") = prevquarter refdate - fix ("","this","quarter") = thisquarter refdate - fix ("","next","quarter") = nextquarter refdate - fix ("","last","year") = prevyear refdate - fix ("","this","year") = thisyear refdate - fix ("","next","year") = nextyear refdate - fix ("","",d) = fromGregorian ry rm (read d) - fix ("",m,"") = fromGregorian ry (read m) 1 - fix ("",m,d) = fromGregorian ry (read m) (read d) - fix (y,"","") = fromGregorian (read y) 1 1 - fix (y,m,"") = fromGregorian (read y) (read m) 1 - fix (y,m,d) = fromGregorian (read y) (read m) (read d) - (ry,rm,rd) = toGregorian refdate - -prevday :: Day -> Day -prevday = addDays (-1) -nextday = addDays 1 -startofday = id - -thisweek = startofweek -prevweek = startofweek . addDays (-7) -nextweek = startofweek . addDays 7 -startofweek day = fromMondayStartWeek y w 1 - where - (y,_,_) = toGregorian day - (w,_) = mondayStartWeek day - -thismonth = startofmonth -prevmonth = startofmonth . addGregorianMonthsClip (-1) -nextmonth = startofmonth . addGregorianMonthsClip 1 -startofmonth day = fromGregorian y m 1 where (y,m,_) = toGregorian day - -thisquarter = startofquarter -prevquarter = startofquarter . addGregorianMonthsClip (-3) -nextquarter = startofquarter . addGregorianMonthsClip 3 -startofquarter day = fromGregorian y (firstmonthofquarter m) 1 - where - (y,m,_) = toGregorian day - firstmonthofquarter m = ((m-1) `div` 3) * 3 + 1 - -thisyear = startofyear -prevyear = startofyear . addGregorianYearsClip (-1) -nextyear = startofyear . addGregorianYearsClip 1 -startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day - ----------------------------------------------------------------------- --- parsing - -firstJust ms = case dropWhile (==Nothing) ms of - [] -> Nothing - (md:_) -> md - --- | Parse a couple of date-time string formats to a time type. -parsedatetimeM :: String -> Maybe LocalTime -parsedatetimeM s = firstJust [ - parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s, - parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s - ] - --- | Parse a couple of date string formats to a time type. -parsedateM :: String -> Maybe Day -parsedateM s = firstJust [ - parseTime defaultTimeLocale "%Y/%m/%d" s, - parseTime defaultTimeLocale "%Y-%m-%d" s - ] - --- | Parse a date-time string to a time type, or raise an error. -parsedatetime :: String -> LocalTime -parsedatetime s = fromMaybe (error $ "could not parse timestamp \"" ++ s ++ "\"") - (parsedatetimeM s) - --- | Parse a date string to a time type, or raise an error. -parsedate :: String -> Day -parsedate s = fromMaybe (error $ "could not parse date \"" ++ s ++ "\"") - (parsedateM s) - --- | Parse a time string to a time type using the provided pattern, or --- return the default. -parsetimewith :: ParseTime t => String -> String -> t -> t -parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s - -{-| -Parse a date in any of the formats allowed in ledger's period expressions, -and maybe some others: - -> 2004 -> 2004/10 -> 2004/10/1 -> 10/1 -> 21 -> october, oct -> yesterday, today, tomorrow -> (not yet) this/next/last week/day/month/quarter/year - -Returns a SmartDate, to be converted to a full date later (see fixSmartDate). -Assumes any text in the parse stream has been lowercased. --} -smartdate :: GenParser Char st SmartDate -smartdate = do - let dateparsers = [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, - lastthisnextthing - ] - (y,m,d) <- choice $ map try dateparsers - return (y,m,d) - --- | Like smartdate, but there must be nothing other than whitespace after the date. -smartdateonly :: GenParser Char st SmartDate -smartdateonly = do - d <- smartdate - many spacenonewline - eof - return d - -datesepchar = oneOf "/-." - -yyyymmdd :: GenParser Char st SmartDate -yyyymmdd = do - y <- count 4 digit - m <- count 2 digit - guard (read m <= 12) - d <- count 2 digit - guard (read d <= 31) - return (y,m,d) - -ymd :: GenParser Char st SmartDate -ymd = do - y <- many1 digit - datesepchar - m <- try (count 2 digit) <|> count 1 digit - when (read m < 1 || (read m > 12)) $ error $ "bad month number: " ++ m - datesepchar - d <- try (count 2 digit) <|> count 1 digit - when (read d < 1 || (read d > 31)) $ error $ "bad day number: " ++ d - return $ (y,m,d) - -ym :: GenParser Char st SmartDate -ym = do - y <- many1 digit - guard (read y > 12) - datesepchar - m <- try (count 2 digit) <|> count 1 digit - guard (read m >= 1 && (read m <= 12)) - return (y,m,"") - -y :: GenParser Char st SmartDate -y = do - y <- many1 digit - guard (read y >= 1000) - return (y,"","") - -d :: GenParser Char st SmartDate -d = do - d <- many1 digit - guard (read d <= 31) - return ("","",d) - -md :: GenParser Char st SmartDate -md = do - m <- try (count 2 digit) <|> count 1 digit - guard (read m >= 1 && (read m <= 12)) - datesepchar - d <- try (count 2 digit) <|> count 1 digit - when (read d < 1 || (read d > 31)) $ fail "bad day number specified" - return ("",m,d) - -months = ["january","february","march","april","may","june", - "july","august","september","october","november","december"] -monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"] -weekdays = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"] -weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"] - -monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months -monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs - -month :: GenParser Char st SmartDate -month = do - m <- choice $ map (try . string) months - let i = monthIndex m - return ("",show i,"") - -mon :: GenParser Char st SmartDate -mon = do - m <- choice $ map (try . string) monthabbrevs - let i = monIndex m - return ("",show i,"") - -today,yesterday,tomorrow :: GenParser Char st SmartDate -today = string "today" >> return ("","","today") -yesterday = string "yesterday" >> return ("","","yesterday") -tomorrow = string "tomorrow" >> return ("","","tomorrow") - -lastthisnextthing :: GenParser Char st SmartDate -lastthisnextthing = do - r <- choice [ - string "last" - ,string "this" - ,string "next" - ] - many spacenonewline -- make the space optional for easier scripting - p <- choice [ - string "day" - ,string "week" - ,string "month" - ,string "quarter" - ,string "year" - ] --- XXX support these in fixSmartDate --- ++ (map string $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs) - - return ("",r,p) - -periodexpr :: Day -> GenParser Char st (Interval, DateSpan) -periodexpr rdate = choice $ map try [ - intervalanddateperiodexpr rdate, - intervalperiodexpr, - dateperiodexpr rdate, - (return (NoInterval,DateSpan Nothing Nothing)) - ] - -intervalanddateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) -intervalanddateperiodexpr rdate = do - many spacenonewline - i <- periodexprinterval - many spacenonewline - s <- periodexprdatespan rdate - return (i,s) - -intervalperiodexpr :: GenParser Char st (Interval, DateSpan) -intervalperiodexpr = do - many spacenonewline - i <- periodexprinterval - return (i, DateSpan Nothing Nothing) - -dateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) -dateperiodexpr rdate = do - many spacenonewline - s <- periodexprdatespan rdate - return (NoInterval, s) - -periodexprinterval :: GenParser Char st Interval -periodexprinterval = - choice $ map try [ - tryinterval "day" "daily" Daily, - tryinterval "week" "weekly" Weekly, - tryinterval "month" "monthly" Monthly, - tryinterval "quarter" "quarterly" Quarterly, - tryinterval "year" "yearly" Yearly - ] - where - tryinterval s1 s2 v = - choice [try (string $ "every "++s1), try (string s2)] >> return v - -periodexprdatespan :: Day -> GenParser Char st DateSpan -periodexprdatespan rdate = choice $ map try [ - doubledatespan rdate, - fromdatespan rdate, - todatespan rdate, - justdatespan rdate - ] - -doubledatespan :: Day -> GenParser Char st DateSpan -doubledatespan rdate = do - optional (string "from" >> many spacenonewline) - b <- smartdate - many spacenonewline - optional (string "to" >> many spacenonewline) - e <- smartdate - return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) - -fromdatespan :: Day -> GenParser Char st DateSpan -fromdatespan rdate = do - string "from" >> many spacenonewline - b <- smartdate - return $ DateSpan (Just $ fixSmartDate rdate b) Nothing - -todatespan :: Day -> GenParser Char st DateSpan -todatespan rdate = do - string "to" >> many spacenonewline - e <- smartdate - return $ DateSpan Nothing (Just $ fixSmartDate rdate e) - -justdatespan :: Day -> GenParser Char st DateSpan -justdatespan rdate = do - optional (string "in" >> many spacenonewline) - d <- smartdate - return $ spanFromSmartDate rdate d - -mkdatespan :: String -> String -> DateSpan -mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate - -nulldatespan = DateSpan Nothing Nothing - -nulldate = parsedate "1900/01/01" - -tests_Dates = TestList [ - - "splitSpan" ~: do - let gives (interval, span) = (splitSpan interval span `is`) - (NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives` - [mkdatespan "2008/01/01" "2009/01/01"] - (Quarterly,mkdatespan "2008/01/01" "2009/01/01") `gives` - [mkdatespan "2008/01/01" "2008/04/01" - ,mkdatespan "2008/04/01" "2008/07/01" - ,mkdatespan "2008/07/01" "2008/10/01" - ,mkdatespan "2008/10/01" "2009/01/01" - ] - (Quarterly,nulldatespan) `gives` - [nulldatespan] - (Daily,mkdatespan "2008/01/01" "2008/01/01") `gives` - [mkdatespan "2008/01/01" "2008/01/01"] - (Quarterly,mkdatespan "2008/01/01" "2008/01/01") `gives` - [mkdatespan "2008/01/01" "2008/01/01"] - - ] diff --git a/Ledger/IO.hs b/Ledger/IO.hs deleted file mode 100644 --- a/Ledger/IO.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| -Utilities for doing I/O with ledger files. --} - -module Ledger.IO -where -import Control.Monad.Error -import Ledger.Ledger (cacheLedger', nullledger) -import Ledger.Parse (parseLedger) -import Ledger.Types (FilterSpec(..),WhichDate(..),Journal(..),Ledger(..)) -import Ledger.Utils (getCurrentLocalTime) -import Ledger.Dates (nulldatespan) -import System.Directory (getHomeDirectory) -import System.Environment (getEnv) -#if __GLASGOW_HASKELL__ <= 610 -import Prelude hiding (readFile) -import System.IO.UTF8 -#endif -import System.FilePath (()) -import System.Time (getClockTime) - - -ledgerenvvar = "LEDGER" -timelogenvvar = "TIMELOG" -ledgerdefaultfilename = ".ledger" -timelogdefaultfilename = ".timelog" - -nullfilterspec = FilterSpec { - datespan=nulldatespan - ,cleared=Nothing - ,real=False - ,empty=False - ,costbasis=False - ,acctpats=[] - ,descpats=[] - ,whichdate=ActualDate - ,depth=Nothing - } - --- | Get the user's default ledger file path. -myLedgerPath :: IO String -myLedgerPath = - getEnv ledgerenvvar `catch` - (\_ -> do - home <- getHomeDirectory `catch` (\_ -> return "") - return $ home ledgerdefaultfilename) - --- | Get the user's default timelog file path. -myTimelogPath :: IO String -myTimelogPath = - getEnv timelogenvvar `catch` - (\_ -> do - home <- getHomeDirectory - return $ home timelogdefaultfilename) - --- | Read the user's default ledger file, or give an error. -myLedger :: IO Ledger -myLedger = myLedgerPath >>= readLedger - --- | Read the user's default timelog file, or give an error. -myTimelog :: IO Ledger -myTimelog = myTimelogPath >>= readLedger - --- | Read a ledger from this file, with no filtering, or give an error. -readLedger :: FilePath -> IO Ledger -readLedger f = do - t <- getClockTime - s <- readFile f - j <- journalFromString s - return $ cacheLedger' $ nullledger{journal=j{filepath=f,filereadtime=t,jtext=s}} - --- -- | Read a ledger from this file, filtering according to the filter spec., --- -- | or give an error. --- readLedgerWithFilterSpec :: FilterSpec -> FilePath -> IO Ledger --- readLedgerWithFilterSpec fspec f = do --- s <- readFile f --- t <- getClockTime --- rl <- journalFromString s --- return $ filterAndCacheLedger fspec s rl{filepath=f, filereadtime=t} - --- | Read a Journal from the given string, using the current time as --- reference time, or give a parse error. -journalFromString :: String -> IO Journal -journalFromString s = do - t <- getCurrentLocalTime - liftM (either error id) $ runErrorT $ parseLedger t "(string)" s - --- -- | 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 - diff --git a/Ledger/Journal.hs b/Ledger/Journal.hs deleted file mode 100644 --- a/Ledger/Journal.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-| - -A 'Journal' is a parsed ledger file, containing 'Transaction's. -It can be filtered and massaged in various ways, then \"crunched\" -to form a 'Ledger'. - --} - -module Ledger.Journal -where -import qualified Data.Map as Map -import Data.Map (findWithDefault, (!)) -import System.Time (ClockTime(TOD)) -import Ledger.Utils -import Ledger.Types -import Ledger.AccountName -import Ledger.Amount -import Ledger.Transaction (ledgerTransactionWithDate) -import Ledger.Posting -import Ledger.TimeLog - - -instance Show Journal where - show j = printf "Journal with %d transactions, %d accounts: %s" - (length (jtxns j) + - length (jmodifiertxns j) + - length (jperiodictxns j)) - (length accounts) - (show accounts) - -- ++ (show $ journalTransactions l) - where accounts = flatten $ journalAccountNameTree j - -nulljournal :: Journal -nulljournal = Journal { jmodifiertxns = [] - , jperiodictxns = [] - , jtxns = [] - , open_timelog_entries = [] - , historical_prices = [] - , final_comment_lines = [] - , filepath = "" - , filereadtime = TOD 0 0 - , jtext = "" - } - -addTransaction :: Transaction -> Journal -> Journal -addTransaction t l0 = l0 { jtxns = t : jtxns l0 } - -addModifierTransaction :: ModifierTransaction -> Journal -> Journal -addModifierTransaction mt l0 = l0 { jmodifiertxns = mt : jmodifiertxns l0 } - -addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal -addPeriodicTransaction pt l0 = l0 { jperiodictxns = pt : jperiodictxns l0 } - -addHistoricalPrice :: HistoricalPrice -> Journal -> Journal -addHistoricalPrice h l0 = l0 { historical_prices = h : historical_prices l0 } - -addTimeLogEntry :: TimeLogEntry -> Journal -> Journal -addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : open_timelog_entries l0 } - -journalPostings :: Journal -> [Posting] -journalPostings = concatMap tpostings . jtxns - -journalAccountNamesUsed :: Journal -> [AccountName] -journalAccountNamesUsed = accountNamesFromPostings . journalPostings - -journalAccountNames :: Journal -> [AccountName] -journalAccountNames = sort . expandAccountNames . journalAccountNamesUsed - -journalAccountNameTree :: Journal -> Tree AccountName -journalAccountNameTree = accountNameTreeFrom . journalAccountNames - --- 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. -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 - --- | 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. -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 . - filterJournalPostingsByClearedStatus cleared . - filterJournalPostingsByEmpty empty . - filterJournalPostingsByDepth depth . - filterJournalPostingsByAccount apats . - filterJournalTransactionsByDescription dpats . - filterJournalTransactionsByDate datespan . - journalSelectingDate whichdate - --- | Keep only ledger transactions whose description matches the description patterns. -filterJournalTransactionsByDescription :: [String] -> Journal -> Journal -filterJournalTransactionsByDescription pats j@Journal{jtxns=ts} = j{jtxns=filter matchdesc ts} - where matchdesc = matchpats pats . tdescription - --- | Keep only ledger transactions which fall between begin and end dates. --- We include transactions on the begin date and exclude transactions on the end --- date, like ledger. An empty date string means no restriction. -filterJournalTransactionsByDate :: DateSpan -> Journal -> Journal -filterJournalTransactionsByDate (DateSpan begin end) j@Journal{jtxns=ts} = j{jtxns=filter match ts} - where match t = maybe True (tdate t>=) begin && maybe True (tdate t<) end - --- | Keep only ledger transactions which have the requested --- cleared/uncleared status, if there is one. -filterJournalTransactionsByClearedStatus :: Maybe Bool -> Journal -> Journal -filterJournalTransactionsByClearedStatus Nothing j = j -filterJournalTransactionsByClearedStatus (Just val) j@Journal{jtxns=ts} = j{jtxns=filter match ts} - where match = (==val).tstatus - --- | Keep only postings which have the requested cleared/uncleared status, --- if there is one. -filterJournalPostingsByClearedStatus :: Maybe Bool -> Journal -> Journal -filterJournalPostingsByClearedStatus Nothing j = j -filterJournalPostingsByClearedStatus (Just c) j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} - where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter ((==c) . postingCleared) ps} - --- | Strip out any virtual postings, if the flag is true, otherwise do --- no filtering. -filterJournalPostingsByRealness :: Bool -> Journal -> Journal -filterJournalPostingsByRealness False l = l -filterJournalPostingsByRealness True j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} - where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter isReal ps} - --- | Strip out any postings with zero amount, unless the flag is true. -filterJournalPostingsByEmpty :: Bool -> Journal -> Journal -filterJournalPostingsByEmpty True l = l -filterJournalPostingsByEmpty False j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} - where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (not . isEmptyPosting) ps} - --- | Keep only transactions which affect accounts deeper than the specified depth. -filterJournalTransactionsByDepth :: Maybe Int -> Journal -> Journal -filterJournalTransactionsByDepth Nothing j = j -filterJournalTransactionsByDepth (Just d) j@Journal{jtxns=ts} = - j{jtxns=(filter (any ((<= d+1) . accountNameLevel . paccount) . tpostings) ts)} - --- | Strip out any postings to accounts deeper than the specified depth --- (and any ledger transactions which have no postings as a result). -filterJournalPostingsByDepth :: Maybe Int -> Journal -> Journal -filterJournalPostingsByDepth Nothing j = j -filterJournalPostingsByDepth (Just d) j@Journal{jtxns=ts} = - j{jtxns=filter (not . null . tpostings) $ map filtertxns ts} - where filtertxns t@Transaction{tpostings=ps} = - t{tpostings=filter ((<= d) . accountNameLevel . paccount) ps} - --- | Keep only transactions which affect accounts matched by the account patterns. -filterJournalTransactionsByAccount :: [String] -> Journal -> Journal -filterJournalTransactionsByAccount apats j@Journal{jtxns=ts} = j{jtxns=filter match ts} - where match = any (matchpats apats . paccount) . tpostings - --- | Keep only postings which affect accounts matched by the account patterns. --- This can leave transactions unbalanced. -filterJournalPostingsByAccount :: [String] -> Journal -> Journal -filterJournalPostingsByAccount apats j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} - where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (matchpats apats . paccount) ps} - --- | Convert this journal's transactions' primary date to either the --- actual or effective date. -journalSelectingDate :: WhichDate -> Journal -> Journal -journalSelectingDate ActualDate j = j -journalSelectingDate EffectiveDate j = - j{jtxns=map (ledgerTransactionWithDate EffectiveDate) $ jtxns j} - --- | Convert all the journal's amounts to their canonical display settings. --- Ie, in each commodity, amounts will use the display settings of the first --- amount detected, and the greatest precision of the amounts detected. --- Also, missing unit prices are added if known from the price history. --- Also, amounts are converted to cost basis if that flag is active. --- XXX refactor -canonicaliseAmounts :: Bool -> Journal -> Journal -canonicaliseAmounts costbasis j@Journal{jtxns=ts} = j{jtxns=map fixledgertransaction ts} - where - fixledgertransaction (Transaction d ed s c de co ts pr) = Transaction d ed s c de co (map fixrawposting ts) pr - where - fixrawposting (Posting s ac a c t txn) = Posting s ac (fixmixedamount a) c t txn - fixmixedamount (Mixed as) = Mixed $ map fixamount as - fixamount = (if costbasis then costOfAmount else id) . fixprice . fixcommodity - fixcommodity a = a{commodity=c} where c = canonicalcommoditymap ! symbol (commodity a) - canonicalcommoditymap = - Map.fromList [(s,firstc{precision=maxp}) | s <- commoditysymbols, - let cs = commoditymap ! s, - let firstc = head cs, - let maxp = maximum $ map precision cs - ] - commoditymap = Map.fromList [(s,commoditieswithsymbol s) | s <- commoditysymbols] - commoditieswithsymbol s = filter ((s==) . symbol) commodities - commoditysymbols = nub $ map symbol commodities - commodities = map commodity (concatMap (amounts . pamount) (journalPostings j) - ++ concatMap (amounts . hamount) (historical_prices j)) - fixprice :: Amount -> Amount - fixprice a@Amount{price=Just _} = a - fixprice a@Amount{commodity=c} = a{price=journalHistoricalPriceFor j d c} - - -- | Get the price for a commodity on the specified day from the price database, if known. - -- Does only one lookup step, ie will not look up the price of a price. - journalHistoricalPriceFor :: Journal -> Day -> Commodity -> Maybe MixedAmount - journalHistoricalPriceFor j d Commodity{symbol=s} = do - let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices j - case ps of (HistoricalPrice{hamount=a}:_) -> Just $ canonicaliseCommodities a - _ -> Nothing - where - canonicaliseCommodities (Mixed as) = Mixed $ map canonicaliseCommodity as - where canonicaliseCommodity a@Amount{commodity=Commodity{symbol=s}} = - a{commodity=findWithDefault (error "programmer error: canonicaliseCommodity failed") s canonicalcommoditymap} - --- | Get just the amounts from a ledger, in the order parsed. -journalAmounts :: Journal -> [MixedAmount] -journalAmounts = map pamount . journalPostings - --- | Get just the ammount commodities from a ledger, in the order parsed. -journalCommodities :: Journal -> [Commodity] -journalCommodities = map commodity . concatMap amounts . journalAmounts - --- | Get just the amount precisions from a ledger, in the order parsed. -journalPrecisions :: Journal -> [Int] -journalPrecisions = map precision . journalCommodities - --- | Close any open timelog sessions using the provided current time. -journalConvertTimeLog :: LocalTime -> Journal -> Journal -journalConvertTimeLog t l0 = l0 { jtxns = convertedTimeLog ++ jtxns l0 - , open_timelog_entries = [] - } - where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0 - --- | The (fully specified) date span containing all the raw ledger's transactions, --- or DateSpan Nothing Nothing if there are none. -journalDateSpan :: Journal -> DateSpan -journalDateSpan j - | null ts = DateSpan Nothing Nothing - | otherwise = DateSpan (Just $ tdate $ head ts) (Just $ addDays 1 $ tdate $ last ts) - where - ts = sortBy (comparing tdate) $ jtxns j - --- | Check if a set of ledger account/description patterns matches the --- given account name or entry description. Patterns are case-insensitive --- regular expression strings; those beginning with - are anti-patterns. -matchpats :: [String] -> String -> Bool -matchpats pats str = - (null positives || any match positives) && (null negatives || not (any match negatives)) - where - (negatives,positives) = partition isnegativepat pats - match "" = True - match pat = containsRegex (abspat pat) str - negateprefix = "not:" - isnegativepat = (negateprefix `isPrefixOf`) - abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat - --- | Calculate the account tree and account balances from a journal's --- postings, and return the results for efficient lookup. -crunchJournal :: Journal -> (Tree AccountName, Map.Map AccountName Account) -crunchJournal j = (ant,amap) - where - (ant,psof,_,inclbalof) = (groupPostings . journalPostings) j - amap = Map.fromList [(a, acctinfo a) | a <- flatten ant] - acctinfo a = Account a (psof a) (inclbalof a) - --- | Given a list of postings, return an account name tree and three query --- functions that fetch postings, balance, and subaccount-including --- balance by account name. This factors out common logic from --- cacheLedger and summarisePostingsInDateSpan. -groupPostings :: [Posting] -> (Tree AccountName, - (AccountName -> [Posting]), - (AccountName -> MixedAmount), - (AccountName -> MixedAmount)) -groupPostings ps = (ant,psof,exclbalof,inclbalof) - where - anames = sort $ nub $ map paccount ps - ant = accountNameTreeFrom $ expandAccountNames anames - allanames = flatten ant - pmap = Map.union (postingsByAccount ps) (Map.fromList [(a,[]) | a <- allanames]) - psof = (pmap !) - balmap = Map.fromList $ flatten $ calculateBalances ant psof - exclbalof = fst . (balmap !) - inclbalof = snd . (balmap !) - --- | Add subaccount-excluding and subaccount-including balances to a tree --- of account names somewhat efficiently, given a function that looks up --- transactions by account name. -calculateBalances :: Tree AccountName -> (AccountName -> [Posting]) -> Tree (AccountName, (MixedAmount, MixedAmount)) -calculateBalances ant psof = addbalances ant - where - addbalances (Node a subs) = Node (a,(bal,bal+subsbal)) subs' - where - bal = sumPostings $ psof a - subsbal = sum $ map (snd . snd . root) subs' - subs' = map addbalances subs - --- | Convert a list of postings to a map from account name to that --- account's postings. -postingsByAccount :: [Posting] -> Map.Map AccountName [Posting] -postingsByAccount ps = m' - where - sortedps = sortBy (comparing paccount) ps - groupedps = groupBy (\p1 p2 -> paccount p1 == paccount p2) sortedps - m' = Map.fromList [(paccount $ head g, g) | g <- groupedps] diff --git a/Ledger/Ledger.hs b/Ledger/Ledger.hs deleted file mode 100644 --- a/Ledger/Ledger.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-| - -A compound data type for efficiency. A 'Ledger' caches information derived -from a 'Journal' for easier querying. Also it typically has had -uninteresting 'Transaction's and 'Posting's filtered out. It -contains: - -- the original unfiltered 'Journal' - -- a tree of 'AccountName's - -- a map from account names to 'Account's - -- the full text of the journal file, when available - -This is the main object you'll deal with as a user of the Ledger -library. The most useful functions also have shorter, lower-case -aliases for easier interaction. Here's an example: - -> > import Ledger -> > l <- readLedger "sample.ledger" -> > accountnames l -> ["assets","assets:bank","assets:bank:checking","assets:bank:saving",... -> > accounts l -> [Account assets with 0 txns and $-1 balance,Account assets:bank with... -> > topaccounts l -> [Account assets with 0 txns and $-1 balance,Account expenses with... -> > account l "assets" -> Account assets with 0 txns and $-1 balance -> > accountsmatching ["ch"] l -> accountsmatching ["ch"] l -> [Account assets:bank:checking with 4 txns and $0 balance] -> > subaccounts l (account l "assets") -> subaccounts l (account l "assets") -> [Account assets:bank with 0 txns and $1 balance,Account assets:cash... -> > head $ transactions l -> 2008/01/01 income assets:bank:checking $1 RegularPosting -> > accounttree 2 l -> Node {rootLabel = Account top with 0 txns and 0 balance, subForest = [... -> > accounttreeat l (account l "assets") -> Just (Node {rootLabel = Account assets with 0 txns and $-1 balance, ... -> > datespan l -- disabled -> DateSpan (Just 2008-01-01) (Just 2009-01-01) -> > rawdatespan l -> DateSpan (Just 2008-01-01) (Just 2009-01-01) -> > ledgeramounts l -> [$1,$-1,$1,$-1,$1,$-1,$1,$1,$-2,$1,$-1] -> > commodities l -> [Commodity {symbol = "$", side = L, spaced = False, comma = False, ... - - --} - -module Ledger.Ledger -where -import qualified Data.Map as Map -import Data.Map (findWithDefault, fromList) -import Ledger.Utils -import Ledger.Types -import Ledger.Account (nullacct) -import Ledger.AccountName -import Ledger.Journal -import Ledger.Posting - - -instance Show Ledger where - show l = printf "Ledger with %d transactions, %d accounts\n%s" - (length (jtxns $ journal l) + - length (jmodifiertxns $ journal l) + - length (jperiodictxns $ journal l)) - (length $ accountnames l) - (showtree $ accountnametree l) - -nullledger :: Ledger -nullledger = Ledger{ - journal = nulljournal, - accountnametree = nullaccountnametree, - accountmap = fromList [] - } - --- | Convert a journal to a more efficient cached ledger, described above. -cacheLedger :: Journal -> Ledger -cacheLedger j = nullledger{journal=j,accountnametree=ant,accountmap=amap} - where (ant, amap) = crunchJournal j - --- | Add (or recalculate) the cached journal info in a ledger. -cacheLedger' :: Ledger -> CachedLedger -cacheLedger' l = l{accountnametree=ant,accountmap=amap} - where (ant, amap) = crunchJournal $ journal l - --- | Like cacheLedger, but filtering the journal first. -cacheLedger'' filterspec l@Ledger{journal=j} = l{journal=j',accountnametree=ant,accountmap=amap} - where (ant, amap) = crunchJournal j' - j' = filterJournalPostings filterspec{depth=Nothing} j - -type CachedLedger = Ledger - --- | List a ledger's account names. -ledgerAccountNames :: Ledger -> [AccountName] -ledgerAccountNames = drop 1 . flatten . accountnametree - --- | Get the named account from a (cached) ledger. --- If the ledger has not been cached (with crunchJournal or --- cacheLedger'), this returns the null account. -ledgerAccount :: Ledger -> AccountName -> Account -ledgerAccount l a = findWithDefault nullacct a $ accountmap l - --- | List a ledger's accounts, in tree order -ledgerAccounts :: Ledger -> [Account] -ledgerAccounts = drop 1 . flatten . ledgerAccountTree 9999 - --- | List a ledger's top-level accounts, in tree order -ledgerTopAccounts :: Ledger -> [Account] -ledgerTopAccounts = map root . branches . ledgerAccountTree 9999 - --- | Accounts in ledger whose name matches the pattern, in tree order. -ledgerAccountsMatching :: [String] -> Ledger -> [Account] -ledgerAccountsMatching pats = filter (matchpats pats . aname) . accounts - --- | List a ledger account's immediate subaccounts -ledgerSubAccounts :: Ledger -> Account -> [Account] -ledgerSubAccounts l Account{aname=a} = - map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ accountnames l - --- | List a ledger's postings, in the order parsed. -ledgerPostings :: Ledger -> [Posting] -ledgerPostings = journalPostings . journal - --- | Get a ledger's tree of accounts to the specified depth. -ledgerAccountTree :: Int -> Ledger -> Tree Account -ledgerAccountTree depth l = treemap (ledgerAccount l) $ treeprune depth $ accountnametree l - --- | Get a ledger's tree of accounts rooted at the specified account. -ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account) -ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l - --- | The (fully specified) date span containing all the ledger's (filtered) transactions, --- or DateSpan Nothing Nothing if there are none. -ledgerDateSpan :: Ledger -> DateSpan -ledgerDateSpan = postingsDateSpan . ledgerPostings - --- | Convenience aliases. -accountnames :: Ledger -> [AccountName] -accountnames = ledgerAccountNames - -account :: Ledger -> AccountName -> Account -account = ledgerAccount - -accounts :: Ledger -> [Account] -accounts = ledgerAccounts - -topaccounts :: Ledger -> [Account] -topaccounts = ledgerTopAccounts - -accountsmatching :: [String] -> Ledger -> [Account] -accountsmatching = ledgerAccountsMatching - -subaccounts :: Ledger -> Account -> [Account] -subaccounts = ledgerSubAccounts - -postings :: Ledger -> [Posting] -postings = ledgerPostings - -commodities :: Ledger -> [Commodity] -commodities = nub . journalCommodities . journal - -accounttree :: Int -> Ledger -> Tree Account -accounttree = ledgerAccountTree - -accounttreeat :: Ledger -> Account -> Maybe (Tree Account) -accounttreeat = ledgerAccountTreeAt - --- datespan :: Ledger -> DateSpan --- datespan = ledgerDateSpan - -rawdatespan :: Ledger -> DateSpan -rawdatespan = journalDateSpan . journal - -ledgeramounts :: Ledger -> [MixedAmount] -ledgeramounts = journalAmounts . journal diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs deleted file mode 100644 --- a/Ledger/Parse.hs +++ /dev/null @@ -1,732 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| - -Parsers for standard ledger and timelog files. - -Here is the ledger grammar from the ledger 2.5 manual: - -@ -The ledger file format is quite simple, but also very flexible. It supports -many options, though typically the user can ignore most of them. They are -summarized below. The initial character of each line determines what the -line means, and how it should be interpreted. Allowable initial characters -are: - -NUMBER A line beginning with a number denotes an entry. It may be followed by any - number of lines, each beginning with whitespace, to denote the entry’s account - transactions. The format of the first line is: - - DATE[=EDATE] [*|!] [(CODE)] DESC - - If ‘*’ appears after the date (with optional effective date), it indicates the entry - is “cleared”, which can mean whatever the user wants it t omean. If ‘!’ appears - after the date, it indicates d the entry is “pending”; i.e., tentatively cleared from - the user’s point of view, but not yet actually cleared. If a ‘CODE’ appears in - parentheses, it may be used to indicate a check number, or the type of the - transaction. Following these is the payee, or a description of the transaction. - The format of each following transaction is: - - ACCOUNT AMOUNT [; NOTE] - - The ‘ACCOUNT’ may be surrounded by parentheses if it is a virtual - transactions, or square brackets if it is a virtual transactions that must - balance. The ‘AMOUNT’ can be followed by a per-unit transaction cost, - by specifying ‘ AMOUNT’, or a complete transaction cost with ‘\@ AMOUNT’. - Lastly, the ‘NOTE’ may specify an actual and/or effective date for the - transaction by using the syntax ‘[ACTUAL_DATE]’ or ‘[=EFFECTIVE_DATE]’ or - ‘[ACTUAL_DATE=EFFECtIVE_DATE]’. - -= An automated entry. A value expression must appear after the equal sign. - After this initial line there should be a set of one or more transactions, just as - if it were normal entry. If the amounts of the transactions have no commodity, - they will be applied as modifiers to whichever real transaction is matched by - the value expression. - -~ A period entry. A period expression must appear after the tilde. - After this initial line there should be a set of one or more transactions, just as - if it were normal entry. - -! A line beginning with an exclamation mark denotes a command directive. It - must be immediately followed by the command word. The supported commands - are: - - ‘!include’ - Include the stated ledger file. - ‘!account’ - The account name is given is taken to be the parent of all transac- - tions that follow, until ‘!end’ is seen. - ‘!end’ Ends an account block. - -; A line beginning with a colon indicates a comment, and is ignored. - -Y If a line begins with a capital Y, it denotes the year used for all subsequent - entries that give a date without a year. The year should appear immediately - after the Y, for example: ‘Y2004’. This is useful at the beginning of a file, to - specify the year for that file. If all entries specify a year, however, this command - has no effect. - - -P Specifies a historical price for a commodity. These are usually found in a pricing - history file (see the ‘-Q’ option). The syntax is: - - P DATE SYMBOL PRICE - -N SYMBOL Indicates that pricing information is to be ignored for a given symbol, nor will - quotes ever be downloaded for that symbol. Useful with a home currency, such - as the dollar ($). It is recommended that these pricing options be set in the price - database file, which defaults to ‘~/.pricedb’. The syntax for this command is: - - N SYMBOL - - -D AMOUNT Specifies the default commodity to use, by specifying an amount in the expected - format. The entry command will use this commodity as the default when none - other can be determined. This command may be used multiple times, to set - the default flags for different commodities; whichever is seen last is used as the - default commodity. For example, to set US dollars as the default commodity, - while also setting the thousands flag and decimal flag for that commodity, use: - - D $1,000.00 - -C AMOUNT1 = AMOUNT2 - Specifies a commodity conversion, where the first amount is given to be equiv- - alent to the second amount. The first amount should use the decimal precision - desired during reporting: - - C 1.00 Kb = 1024 bytes - -i, o, b, h - These four relate to timeclock support, which permits ledger to read timelog - files. See the timeclock’s documentation for more info on the syntax of its - timelog files. -@ - -Here is the timelog grammar from timeclock.el 2.6: - -@ -A timelog contains data in the form of a single entry per line. -Each entry has the form: - - CODE YYYY/MM/DD HH:MM:SS [COMMENT] - -CODE is one of: b, h, i, o or O. COMMENT is optional when the code is -i, o or O. The meanings of the codes are: - - b Set the current time balance, or \"time debt\". Useful when - archiving old log data, when a debt must be carried forward. - The COMMENT here is the number of seconds of debt. - - h Set the required working time for the given day. This must - be the first entry for that day. The COMMENT in this case is - the number of hours in this workday. Floating point amounts - are allowed. - - i Clock in. The COMMENT in this case should be the name of the - project worked on. - - o Clock out. COMMENT is unnecessary, but can be used to provide - a description of how the period went, for example. - - O Final clock out. Whatever project was being worked on, it is - now finished. Useful for creating summary reports. -@ - -Example: - -@ -i 2007/03/10 12:26:00 hledger -o 2007/03/10 17:26:02 -@ - --} - -module Ledger.Parse -where -import Control.Monad.Error (ErrorT(..), MonadIO, liftIO, throwError, catchError) -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Char -import Text.ParserCombinators.Parsec.Combinator -import System.Directory -#if __GLASGOW_HASKELL__ <= 610 -import Prelude hiding (readFile, putStr, putStrLn, print, getContents) -import System.IO.UTF8 -#endif -import Ledger.Utils -import Ledger.Types -import Ledger.Dates -import Ledger.AccountName (accountNameFromComponents,accountNameComponents) -import Ledger.Amount -import Ledger.Transaction -import Ledger.Posting -import Ledger.Journal -import Ledger.Commodity (dollars,dollar,unknown) -import System.FilePath(takeDirectory,combine) - - --- | A JournalUpdate is some transformation of a "Journal". It can do I/O --- or raise an error. -type JournalUpdate = ErrorT String IO (Journal -> Journal) - --- | Some context kept during parsing. -data LedgerFileCtx = Ctx { - ctxYear :: !(Maybe Integer) -- ^ the default year most recently specified with Y - , ctxCommod :: !(Maybe String) -- ^ I don't know - , ctxAccount :: ![String] -- ^ the current stack of parent accounts specified by !account - } deriving (Read, Show) - -emptyCtx :: LedgerFileCtx -emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] } - -setYear :: Integer -> GenParser tok LedgerFileCtx () -setYear y = updateState (\ctx -> ctx{ctxYear=Just y}) - -getYear :: GenParser tok LedgerFileCtx (Maybe Integer) -getYear = liftM ctxYear getState - -pushParentAccount :: String -> GenParser tok LedgerFileCtx () -pushParentAccount parent = updateState addParentAccount - where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 } - normalize = (++ ":") - -popParentAccount :: GenParser tok LedgerFileCtx () -popParentAccount = do ctx0 <- getState - case ctxAccount ctx0 of - [] -> unexpected "End of account block with no beginning" - (_:rest) -> setState $ ctx0 { ctxAccount = rest } - -getParentAccount :: GenParser tok LedgerFileCtx String -getParentAccount = liftM (concat . reverse . ctxAccount) getState - -expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath -expandPath pos fp = liftM mkRelative (expandHome fp) - where - mkRelative = combine (takeDirectory (sourceName pos)) - expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory - return $ homedir ++ drop 1 inname - | otherwise = return inname - --- let's get to it - --- | Parses a ledger file or timelog file to a "Journal", or gives an --- error. Requires the current (local) time to calculate any unfinished --- timelog sessions, we pass it in for repeatability. -parseLedgerFile :: LocalTime -> FilePath -> ErrorT String IO Journal -parseLedgerFile t "-" = liftIO getContents >>= parseLedger t "-" -parseLedgerFile t f = liftIO (readFile f) >>= parseLedger t f - --- | Like parseLedgerFile, but parses a string. A file path is still --- provided to save in the resulting journal. -parseLedger :: LocalTime -> FilePath -> String -> ErrorT String IO Journal -parseLedger reftime inname intxt = - case runParser ledgerFile emptyCtx inname intxt of - Right m -> liftM (journalConvertTimeLog reftime) $ m `ap` return nulljournal - Left err -> throwError $ show err -- XXX raises an uncaught exception if we have a parsec user error, eg from many ? - --- parsers - --- | Top-level journal parser. Returns a single composite, I/O performing, --- error-raising "JournalUpdate" which can be applied to an empty journal --- to get the final result. -ledgerFile :: GenParser Char LedgerFileCtx JournalUpdate -ledgerFile = do items <- many ledgerItem - eof - return $ liftM (foldr (.) id) $ sequence items - where - -- 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 - ledgerItem = choice [ ledgerExclamationDirective - , liftM (return . addTransaction) ledgerTransaction - , liftM (return . addModifierTransaction) ledgerModifierTransaction - , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction - , liftM (return . addHistoricalPrice) ledgerHistoricalPrice - , ledgerDefaultYear - , ledgerIgnoredPriceCommodity - , ledgerTagDirective - , ledgerEndTagDirective - , emptyLine >> return (return id) - , liftM (return . addTimeLogEntry) timelogentry - ] - -emptyLine :: GenParser Char st () -emptyLine = do many spacenonewline - optional $ (char ';' "comment") >> many (noneOf "\n") - newline - return () - -ledgercomment :: GenParser Char st String -ledgercomment = do - many1 $ char ';' - many spacenonewline - many (noneOf "\n") - "comment" - -ledgercommentline :: GenParser Char st String -ledgercommentline = do - many spacenonewline - s <- ledgercomment - optional newline - eof - return s - "comment" - -ledgerExclamationDirective :: GenParser Char LedgerFileCtx JournalUpdate -ledgerExclamationDirective = do - char '!' "directive" - directive <- many nonspace - case directive of - "include" -> ledgerInclude - "account" -> ledgerAccountBegin - "end" -> ledgerAccountEnd - _ -> mzero - -ledgerInclude :: GenParser Char LedgerFileCtx JournalUpdate -ledgerInclude = do many1 spacenonewline - filename <- restofline - outerState <- getState - outerPos <- getPosition - let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n" - return $ do contents <- expandPath outerPos filename >>= readFileE outerPos - case runParser ledgerFile outerState filename contents of - Right l -> l `catchError` (throwError . (inIncluded ++)) - Left perr -> throwError $ inIncluded ++ show perr - where readFileE outerPos filename = ErrorT $ liftM Right (readFile filename) `catch` leftError - where leftError err = return $ Left $ currentPos ++ whileReading ++ show err - currentPos = show outerPos - whileReading = " reading " ++ show filename ++ ":\n" - -ledgerAccountBegin :: GenParser Char LedgerFileCtx JournalUpdate -ledgerAccountBegin = do many1 spacenonewline - parent <- ledgeraccountname - newline - pushParentAccount parent - return $ return id - -ledgerAccountEnd :: GenParser Char LedgerFileCtx JournalUpdate -ledgerAccountEnd = popParentAccount >> return (return id) - -ledgerModifierTransaction :: GenParser Char LedgerFileCtx ModifierTransaction -ledgerModifierTransaction = do - char '=' "modifier transaction" - many spacenonewline - valueexpr <- restofline - postings <- ledgerpostings - return $ ModifierTransaction valueexpr postings - -ledgerPeriodicTransaction :: GenParser Char LedgerFileCtx PeriodicTransaction -ledgerPeriodicTransaction = do - char '~' "periodic transaction" - many spacenonewline - periodexpr <- restofline - postings <- ledgerpostings - return $ PeriodicTransaction periodexpr postings - -ledgerHistoricalPrice :: GenParser Char LedgerFileCtx 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 LedgerFileCtx JournalUpdate -ledgerIgnoredPriceCommodity = do - char 'N' "ignored-price commodity" - many1 spacenonewline - commoditysymbol - restofline - return $ return id - -ledgerDefaultCommodity :: GenParser Char LedgerFileCtx JournalUpdate -ledgerDefaultCommodity = do - char 'D' "default commodity" - many1 spacenonewline - someamount - restofline - return $ return id - -ledgerCommodityConversion :: GenParser Char LedgerFileCtx JournalUpdate -ledgerCommodityConversion = do - char 'C' "commodity conversion" - many1 spacenonewline - someamount - many spacenonewline - char '=' - many spacenonewline - someamount - restofline - return $ return id - -ledgerTagDirective :: GenParser Char LedgerFileCtx JournalUpdate -ledgerTagDirective = do - string "tag" "tag directive" - many1 spacenonewline - _ <- many1 nonspace - restofline - return $ return id - -ledgerEndTagDirective :: GenParser Char LedgerFileCtx JournalUpdate -ledgerEndTagDirective = do - string "end tag" "end tag directive" - restofline - return $ return id - --- like ledgerAccountBegin, updates the LedgerFileCtx -ledgerDefaultYear :: GenParser Char LedgerFileCtx JournalUpdate -ledgerDefaultYear = do - char 'Y' "default year" - many spacenonewline - y <- many1 digit - let y' = read y - guard (y' >= 1000) - setYear y' - return $ return id - --- | Try to parse a ledger entry. If we successfully parse an entry, --- check it can be balanced, and fail if not. -ledgerTransaction :: GenParser Char LedgerFileCtx Transaction -ledgerTransaction = do - date <- ledgerdate "transaction" - edate <- try (ledgereffectivedate date "effective date") <|> return Nothing - status <- ledgerstatus - code <- ledgercode - description <- many1 spacenonewline >> liftM rstrip (many (noneOf ";\n") "description") - comment <- ledgercomment <|> return "" - restofline - postings <- ledgerpostings - let t = txnTieKnot $ Transaction date edate status code description comment postings "" - case balanceTransaction t of - Right t' -> return t' - Left err -> fail err - -ledgerdate :: GenParser Char LedgerFileCtx Day -ledgerdate = (try ledgerfulldate <|> ledgerpartialdate) "full or partial date" - -ledgerfulldate :: GenParser Char LedgerFileCtx Day -ledgerfulldate = do - (y,m,d) <- ymd - return $ fromGregorian (read y) (read m) (read d) - --- | Match a partial M/D date in a ledger, and also require that a default --- year directive was previously encountered. -ledgerpartialdate :: GenParser Char LedgerFileCtx Day -ledgerpartialdate = do - (_,m,d) <- md - y <- getYear - when (y==Nothing) $ fail "partial date found, but no default year specified" - return $ fromGregorian (fromJust y) (read m) (read d) - -ledgerdatetime :: GenParser Char LedgerFileCtx LocalTime -ledgerdatetime = do - day <- ledgerdate - many1 spacenonewline - h <- many1 digit - 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 - -ledgereffectivedate :: Day -> GenParser Char LedgerFileCtx (Maybe Day) -ledgereffectivedate actualdate = do - char '=' - -- kludgy way to use actual date for default year - let withDefaultYear d p = do - y <- getYear - let (y',_,_) = toGregorian d in setYear y' - r <- p - when (isJust y) $ setYear $ fromJust y - return r - edate <- withDefaultYear actualdate ledgerdate - return $ Just edate - -ledgerstatus :: GenParser Char st Bool -ledgerstatus = try (do { many1 spacenonewline; char '*' "status"; return True } ) <|> return False - -ledgercode :: GenParser Char st String -ledgercode = try (do { many1 spacenonewline; char '(' "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" - -ledgerpostings :: GenParser Char LedgerFileCtx [Posting] -ledgerpostings = do - -- complicated to handle intermixed comment lines.. please make me better. - ctx <- getState - let parses p = isRight . parseWithCtx ctx p - ls <- many1 $ try linebeginningwithspaces - let ls' = filter (not . (ledgercommentline `parses`)) ls - guard (not $ null ls') - return $ map (fromparse . parseWithCtx ctx ledgerposting) ls' - "postings" - -linebeginningwithspaces :: GenParser Char st String -linebeginningwithspaces = do - sp <- many1 spacenonewline - c <- nonspace - cs <- restofline - return $ sp ++ (c:cs) ++ "\n" - -ledgerposting :: GenParser Char LedgerFileCtx Posting -ledgerposting = do - many1 spacenonewline - status <- ledgerstatus - account <- transactionaccountname - let (ptype, account') = (postingTypeFromAccountName account, unbracket account) - amount <- postingamount - many spacenonewline - comment <- ledgercomment <|> return "" - newline - return (Posting status account' amount comment ptype Nothing) - --- qualify with the parent account from parsing context -transactionaccountname :: GenParser Char LedgerFileCtx AccountName -transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname - --- | 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 --- more components of at least one character, separated by the account --- separator char. -ledgeraccountname :: GenParser Char st AccountName -ledgeraccountname = do - a <- many1 (nonspace <|> singlespace) - let a' = striptrailingspace a - when (accountNameFromComponents (accountNameComponents a') /= a') - (fail $ "accountname seems ill-formed: "++a') - return a' - where - singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}) - -- couldn't avoid consuming a final space sometimes, harmless - striptrailingspace s = if last s == ' ' then init s else s - --- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace --- "account name character (non-bracket, non-parenthesis, non-whitespace)" - --- | Parse an amount, with an optional left or right currency symbol and --- optional price. -postingamount :: GenParser Char st MixedAmount -postingamount = - try (do - many1 spacenonewline - someamount <|> return missingamt - ) <|> return missingamt - -someamount :: GenParser Char st MixedAmount -someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount - -leftsymbolamount :: GenParser Char st MixedAmount -leftsymbolamount = do - sym <- commoditysymbol - sp <- many spacenonewline - (q,p,comma) <- amountquantity - pri <- priceamount - let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,comma=comma,precision=p} - return $ Mixed [Amount c q pri] - "left-symbol amount" - -rightsymbolamount :: GenParser Char st MixedAmount -rightsymbolamount = do - (q,p,comma) <- amountquantity - sp <- many spacenonewline - sym <- commoditysymbol - pri <- priceamount - let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,comma=comma,precision=p} - return $ Mixed [Amount c q pri] - "right-symbol amount" - -nosymbolamount :: GenParser Char st MixedAmount -nosymbolamount = do - (q,p,comma) <- amountquantity - pri <- priceamount - let c = Commodity {symbol="",side=L,spaced=False,comma=comma,precision=p} - return $ Mixed [Amount c q pri] - "no-symbol amount" - -commoditysymbol :: GenParser Char st String -commoditysymbol = (quotedcommoditysymbol <|> - many1 (noneOf "0123456789-.@;\n \"") - ) "commodity symbol" - -quotedcommoditysymbol :: GenParser Char st String -quotedcommoditysymbol = do - char '"' - s <- many1 $ noneOf "-.@;\n \"" - char '"' - return s - -priceamount :: GenParser Char st (Maybe MixedAmount) -priceamount = - try (do - many spacenonewline - char '@' - many spacenonewline - a <- someamount - return $ Just a - ) <|> return Nothing - --- gawd.. trying to parse a ledger number without error: - --- | Parse a ledger-style numeric quantity and also return the number of --- digits to the right of the decimal point and whether thousands are --- separated by comma. -amountquantity :: GenParser Char st (Double, Int, Bool) -amountquantity = do - sign <- optionMaybe $ string "-" - (intwithcommas,frac) <- numberparts - let comma = ',' `elem` intwithcommas - let precision = length frac - -- read the actual value. We expect this read to never fail. - let int = filter (/= ',') intwithcommas - let int' = if null int then "0" else int - let frac' = if null frac then "0" else frac - let sign' = fromMaybe "" sign - let quantity = read $ sign'++int'++"."++frac' - return (quantity, precision, comma) - "commodity quantity" - --- | parse the two strings of digits before and after a possible decimal --- point. The integer part may contain commas, or either part may be --- empty, or there may be no point. -numberparts :: GenParser Char st (String,String) -numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint - -numberpartsstartingwithdigit :: GenParser Char st (String,String) -numberpartsstartingwithdigit = do - let digitorcomma = digit <|> char ',' - first <- digit - rest <- many digitorcomma - frac <- try (do {char '.'; many digit}) <|> return "" - return (first:rest,frac) - -numberpartsstartingwithpoint :: GenParser Char st (String,String) -numberpartsstartingwithpoint = do - char '.' - frac <- many1 digit - return ("",frac) - - --- | Parse a timelog entry. -timelogentry :: GenParser Char LedgerFileCtx TimeLogEntry -timelogentry = do - code <- oneOf "bhioO" - many1 spacenonewline - datetime <- ledgerdatetime - comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline) - return $ TimeLogEntry (read [code]) datetime (fromMaybe "" comment) - - --- | 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 - -compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] - - -tests_Parse = TestList [ - - "ledgerTransaction" ~: do - assertParseEqual (parseWithCtx emptyCtx ledgerTransaction entry1_str) entry1 - assertBool "ledgerTransaction should not parse just a date" - $ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1\n" - assertBool "ledgerTransaction should require some postings" - $ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a\n" - let t = parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a ;comment\n b 1\n" - assertBool "ledgerTransaction should not include a comment in the description" - $ either (const False) ((== "a") . tdescription) t - - ,"ledgerModifierTransaction" ~: do - assertParse (parseWithCtx emptyCtx ledgerModifierTransaction "= (some value expr)\n some:postings 1\n") - - ,"ledgerPeriodicTransaction" ~: do - assertParse (parseWithCtx emptyCtx ledgerPeriodicTransaction "~ (some period expr)\n some:postings 1\n") - - ,"ledgerExclamationDirective" ~: do - assertParse (parseWithCtx emptyCtx ledgerExclamationDirective "!include /some/file.x\n") - assertParse (parseWithCtx emptyCtx ledgerExclamationDirective "!account some:account\n") - assertParse (parseWithCtx emptyCtx (ledgerExclamationDirective >> ledgerExclamationDirective) "!account a\n!end\n") - - ,"ledgercommentline" ~: do - assertParse (parseWithCtx emptyCtx ledgercommentline "; some comment \n") - assertParse (parseWithCtx emptyCtx ledgercommentline " \t; x\n") - assertParse (parseWithCtx emptyCtx ledgercommentline ";x") - - ,"ledgerDefaultYear" ~: do - assertParse (parseWithCtx emptyCtx ledgerDefaultYear "Y 2010\n") - assertParse (parseWithCtx emptyCtx ledgerDefaultYear "Y 10001\n") - - ,"ledgerHistoricalPrice" ~: - assertParseEqual (parseWithCtx emptyCtx ledgerHistoricalPrice "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55]) - - ,"ledgerIgnoredPriceCommodity" ~: do - assertParse (parseWithCtx emptyCtx ledgerIgnoredPriceCommodity "N $\n") - - ,"ledgerDefaultCommodity" ~: do - assertParse (parseWithCtx emptyCtx ledgerDefaultCommodity "D $1,000.0\n") - - ,"ledgerCommodityConversion" ~: do - assertParse (parseWithCtx emptyCtx ledgerCommodityConversion "C 1h = $50.00\n") - - ,"ledgerTagDirective" ~: do - assertParse (parseWithCtx emptyCtx ledgerTagDirective "tag foo \n") - - ,"ledgerEndTagDirective" ~: do - assertParse (parseWithCtx emptyCtx ledgerEndTagDirective "end tag \n") - - ,"ledgeraccountname" ~: do - assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c") - assertBool "ledgeraccountname rejects an empty inner component" (isLeft $ parsewith ledgeraccountname "a::c") - assertBool "ledgeraccountname rejects an empty leading component" (isLeft $ parsewith ledgeraccountname ":b:c") - assertBool "ledgeraccountname rejects an empty trailing component" (isLeft $ parsewith ledgeraccountname "a:b:") - - ,"ledgerposting" ~: do - assertParseEqual (parseWithCtx emptyCtx ledgerposting " expenses:food:dining $10.00\n") - (Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting Nothing) - assertBool "ledgerposting parses a quoted commodity with numbers" - (isRight $ parseWithCtx emptyCtx ledgerposting " a 1 \"DE123\"\n") - - ,"someamount" ~: do - let -- | compare a parse result with a MixedAmount, showing the debug representation for clarity - assertMixedAmountParse parseresult mixedamount = - (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount) - assertMixedAmountParse (parsewith someamount "1 @ $2") - (Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])]) - - ,"postingamount" ~: do - assertParseEqual (parseWithCtx emptyCtx postingamount " $47.18") (Mixed [dollars 47.18]) - assertParseEqual (parseWithCtx emptyCtx postingamount " $1.") - (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing]) - - ] - -entry1_str = unlines - ["2007/01/28 coopportunity" - ," expenses:food:groceries $47.18" - ," assets:checking $-47.18" - ,"" - ] - -entry1 = - txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing, - Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting Nothing] "" - - diff --git a/Ledger/Posting.hs b/Ledger/Posting.hs deleted file mode 100644 --- a/Ledger/Posting.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-| - -A 'Posting' represents a 'MixedAmount' being added to or subtracted from a -single 'Account'. Each 'Transaction' contains two or more postings which -should add up to 0. Postings also reference their parent transaction, so -we can get a date or description for a posting (from the transaction). - --} - -module Ledger.Posting -where -import Ledger.Utils -import Ledger.Types -import Ledger.Amount -import Ledger.AccountName -import Ledger.Dates (nulldate) - - -instance Show Posting where show = showPosting - -nullposting = Posting False "" nullmixedamt "" RegularPosting Nothing - -showPosting :: Posting -> String -showPosting (Posting{paccount=a,pamount=amt,pcomment=com,ptype=t}) = - concatTopPadded [showaccountname a ++ " ", showamount amt, comment] - where - ledger3ishlayout = False - acctnamewidth = if ledger3ishlayout then 25 else 22 - showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width - (bracket,width) = case t of - BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2) - VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2) - _ -> (id,acctnamewidth) - showamount = padleft 12 . showMixedAmountOrZero - comment = if null com then "" else " ; " ++ com --- XXX refactor -showPostingForRegister (Posting{paccount=a,pamount=amt,ptype=t}) = - concatTopPadded [showaccountname a ++ " ", showamount amt] - where - ledger3ishlayout = False - acctnamewidth = if ledger3ishlayout then 25 else 22 - showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width - (bracket,width) = case t of - BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2) - VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2) - _ -> (id,acctnamewidth) - showamount = padleft 12 . showMixedAmountOrZeroWithoutPrice - -isReal :: Posting -> Bool -isReal p = ptype p == RegularPosting - -isVirtual :: Posting -> Bool -isVirtual p = ptype p == VirtualPosting - -isBalancedVirtual :: Posting -> Bool -isBalancedVirtual p = ptype p == BalancedVirtualPosting - -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 - -postingDate :: Posting -> Day -postingDate p = maybe nulldate tdate $ ptransaction p - -postingCleared :: Posting -> Bool -postingCleared p = maybe False tstatus $ ptransaction p - --- | Does this posting fall within the given date span ? -isPostingInDateSpan :: DateSpan -> Posting -> Bool -isPostingInDateSpan (DateSpan Nothing Nothing) _ = True -isPostingInDateSpan (DateSpan Nothing (Just e)) p = postingDate p < e -isPostingInDateSpan (DateSpan (Just b) Nothing) p = postingDate p >= b -isPostingInDateSpan (DateSpan (Just b) (Just e)) p = d >= b && d < e where d = postingDate p - -isEmptyPosting :: Posting -> Bool -isEmptyPosting = isZeroMixedAmount . pamount - --- | Get the minimal date span which contains all the postings, or --- DateSpan Nothing Nothing if there are none. -postingsDateSpan :: [Posting] -> DateSpan -postingsDateSpan [] = DateSpan Nothing Nothing -postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps') - where ps' = sortBy (comparing postingDate) ps - diff --git a/Ledger/TimeLog.hs b/Ledger/TimeLog.hs deleted file mode 100644 --- a/Ledger/TimeLog.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-| - -A 'TimeLogEntry' is a clock-in, clock-out, or other directive in a timelog -file (see timeclock.el or the command-line version). These can be -converted to 'Transactions' and queried like a ledger. - --} - -module Ledger.TimeLog -where -import Ledger.Utils -import Ledger.Types -import Ledger.Dates -import Ledger.Commodity -import Ledger.Transaction - -instance Show TimeLogEntry where - show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t) - -instance Show TimeLogCode where - show SetBalance = "b" - show SetRequiredHours = "h" - show In = "i" - show Out = "o" - show FinalOut = "O" - -instance Read TimeLogCode where - readsPrec _ ('b' : xs) = [(SetBalance, xs)] - readsPrec _ ('h' : xs) = [(SetRequiredHours, xs)] - readsPrec _ ('i' : xs) = [(In, xs)] - readsPrec _ ('o' : xs) = [(Out, xs)] - readsPrec _ ('O' : xs) = [(FinalOut, xs)] - readsPrec _ _ = [] - --- | Convert time log entries to ledger transactions. When there is no --- clockout, add one with the provided current time. Sessions crossing --- midnight are split into days to give accurate per-day totals. -entriesFromTimeLogEntries :: LocalTime -> [TimeLogEntry] -> [Transaction] -entriesFromTimeLogEntries _ [] = [] -entriesFromTimeLogEntries now [i] - | odate > idate = entryFromTimeLogInOut i o' : entriesFromTimeLogEntries now [i',o] - | otherwise = [entryFromTimeLogInOut i o] - where - o = TimeLogEntry Out end "" - end = if itime > now then itime else now - (itime,otime) = (tldatetime i,tldatetime o) - (idate,odate) = (localDay itime,localDay otime) - o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}} - i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}} -entriesFromTimeLogEntries now (i:o:rest) - | odate > idate = entryFromTimeLogInOut i o' : entriesFromTimeLogEntries now (i':o:rest) - | otherwise = entryFromTimeLogInOut i o : entriesFromTimeLogEntries now rest - where - (itime,otime) = (tldatetime i,tldatetime o) - (idate,odate) = (localDay itime,localDay otime) - o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}} - i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}} - --- | Convert a timelog clockin and clockout entry to an equivalent ledger --- entry, representing the time expenditure. Note this entry is not balanced, --- since we omit the \"assets:time\" transaction for simpler output. -entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Transaction -entryFromTimeLogInOut i o - | otime >= itime = t - | otherwise = - error $ "clock-out time less than clock-in time in:\n" ++ showTransaction t - where - t = Transaction { - tdate = idate, - teffectivedate = Nothing, - tstatus = True, - tcode = "", - tdescription = showtime itod ++ "-" ++ showtime otod, - tcomment = "", - tpostings = ps, - tpreceding_comment_lines="" - } - showtime = take 5 . show - acctname = tlcomment i - itime = tldatetime i - otime = tldatetime o - itod = localTimeOfDay itime - otod = localTimeOfDay otime - idate = localDay itime - hrs = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc - amount = Mixed [hours hrs] - ps = [Posting{pstatus=False,paccount=acctname,pamount=amount, - pcomment="",ptype=RegularPosting,ptransaction=Just t} - --,Posting "assets:time" (-amount) "" RegularPosting - ] diff --git a/Ledger/Transaction.hs b/Ledger/Transaction.hs deleted file mode 100644 --- a/Ledger/Transaction.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-| - -A 'Transaction' represents a single balanced entry in the ledger file. It -normally contains two or more balanced 'Posting's. - --} - -module Ledger.Transaction -where -import Ledger.Utils -import Ledger.Types -import Ledger.Dates -import Ledger.Posting -import Ledger.Amount -import Ledger.Commodity (dollars, dollar, unknown) - -instance Show Transaction where show = showTransactionUnelided - -instance Show ModifierTransaction where - show t = "= " ++ mtvalueexpr t ++ "\n" ++ unlines (map show (mtpostings t)) - -instance Show PeriodicTransaction where - show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t)) - -nulltransaction :: Transaction -nulltransaction = Transaction { - tdate=nulldate, - teffectivedate=Nothing, - tstatus=False, - tcode="", - tdescription="", - tcomment="", - tpostings=[], - tpreceding_comment_lines="" - } - -{-| -Show a ledger entry, formatted for the print command. ledger 2.x's -standard format looks like this: - -@ -yyyy/mm/dd[ *][ CODE] description......... [ ; comment...............] - account name 1..................... ...$amount1[ ; comment...............] - account name 2..................... ..$-amount1[ ; comment...............] - -pcodewidth = no limit -- 10 -- mimicking ledger layout. -pdescwidth = no limit -- 20 -- I don't remember what these mean, -pacctwidth = 35 minimum, no maximum -- they were important at the time. -pamtwidth = 11 -pcommentwidth = no limit -- 22 -@ --} -showTransaction :: Transaction -> String -showTransaction = showTransaction' True False - -showTransactionUnelided :: Transaction -> String -showTransactionUnelided = showTransaction' False False - -showTransactionForPrint :: Bool -> Transaction -> String -showTransactionForPrint effective = showTransaction' False effective - -showTransaction' :: Bool -> Bool -> Transaction -> String -showTransaction' elide effective t = - unlines $ [description] ++ showpostings (tpostings t) ++ [""] - where - description = concat [date, status, code, desc, comment] - date | effective = showdate $ fromMaybe (tdate t) $ teffectivedate t - | otherwise = showdate (tdate t) ++ maybe "" showedate (teffectivedate t) - status = if tstatus t then " *" else "" - code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else "" - desc = ' ' : tdescription t - comment = if null com then "" else " ; " ++ com where com = tcomment t - showdate = printf "%-10s" . showDate - showedate = printf "=%s" . showdate - showpostings ps - | elide && length ps > 1 && isTransactionBalanced t - = map showposting (init ps) ++ [showpostingnoamt (last ps)] - | otherwise = map showposting ps - where - showposting p = showacct p ++ " " ++ showamount (pamount p) ++ showcomment (pcomment p) - showpostingnoamt p = rstrip $ showacct p ++ " " ++ showcomment (pcomment p) - showacct p = " " ++ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p)) - w = maximum $ map (length . paccount) ps - showamount = printf "%12s" . showMixedAmountOrZero - showcomment s = if null s then "" else " ; "++s - showstatus p = if pstatus p then "* " else "" - --- | Show an account name, clipped to the given width if any, and --- appropriately bracketed/parenthesised for the given posting type. -showAccountName :: Maybe Int -> PostingType -> AccountName -> String -showAccountName w = fmt - where - fmt RegularPosting = take w' - fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse - fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse - w' = fromMaybe 999999 w - parenthesise s = "("++s++")" - bracket s = "["++s++"]" - -realPostings :: Transaction -> [Posting] -realPostings = filter isReal . tpostings - -virtualPostings :: Transaction -> [Posting] -virtualPostings = filter isVirtual . tpostings - -balancedVirtualPostings :: Transaction -> [Posting] -balancedVirtualPostings = filter isBalancedVirtual . tpostings - --- | Get the sums of a transaction's real, virtual, and balanced virtual postings. -transactionPostingBalances :: Transaction -> (MixedAmount,MixedAmount,MixedAmount) -transactionPostingBalances t = (sumPostings $ realPostings t - ,sumPostings $ virtualPostings t - ,sumPostings $ balancedVirtualPostings t) - --- | Is this transaction balanced ? A balanced transaction's real --- (non-virtual) postings sum to 0, and any balanced virtual postings --- also sum to 0. -isTransactionBalanced :: Transaction -> Bool -isTransactionBalanced t = isReallyZeroMixedAmountCost rsum && isReallyZeroMixedAmountCost bvsum - where (rsum, _, bvsum) = transactionPostingBalances t - --- | Ensure that this entry is balanced, possibly auto-filling a missing --- amount first. We can auto-fill if there is just one non-virtual --- transaction without an amount. The auto-filled balance will be --- converted to cost basis if possible. If the entry can not be balanced, --- return an error message instead. -balanceTransaction :: Transaction -> Either String Transaction -balanceTransaction t@Transaction{tpostings=ps} - | length missingamounts' > 1 = Left $ printerr "could not balance this transaction (too many missing amounts)" - | not $ isTransactionBalanced t' = Left $ printerr $ nonzerobalanceerror t' - | otherwise = Right t' - where - (withamounts, missingamounts) = partition hasAmount $ filter isReal ps - (_, missingamounts') = partition hasAmount ps - t' = t{tpostings=ps'} - ps' | length missingamounts == 1 = map balance ps - | otherwise = ps - where - balance p | isReal p && not (hasAmount p) = p{pamount = costOfMixedAmount (-otherstotal)} - | otherwise = p - where otherstotal = sum $ map pamount withamounts - printerr s = intercalate "\n" [s, showTransactionUnelided t] - -nonzerobalanceerror :: Transaction -> String -nonzerobalanceerror t = printf "could not balance this transaction (%s%s%s)" rmsg sep bvmsg - where - (rsum, _, bvsum) = transactionPostingBalances t - rmsg | isReallyZeroMixedAmountCost rsum = "" - | otherwise = "real postings are off by " ++ show rsum - bvmsg | isReallyZeroMixedAmountCost bvsum = "" - | otherwise = "balanced virtual postings are off by " ++ show bvsum - sep = if not (null rmsg) && not (null bvmsg) then "; " else "" - --- | Convert the primary date to either the actual or effective date. -ledgerTransactionWithDate :: WhichDate -> Transaction -> Transaction -ledgerTransactionWithDate ActualDate t = t -ledgerTransactionWithDate EffectiveDate t = txnTieKnot t{tdate=fromMaybe (tdate t) (teffectivedate t)} - - --- | Ensure a transaction's postings refer back to it. -txnTieKnot :: Transaction -> Transaction -txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (settxn t) ps} - --- | Set a posting's parent transaction. -settxn :: Transaction -> Posting -> Posting -settxn t p = p{ptransaction=Just t} - -tests_Transaction = TestList [ - "showTransaction" ~: do - assertEqual "show a balanced transaction, eliding last amount" - (unlines - ["2007/01/28 coopportunity" - ," expenses:food:groceries $47.18" - ," assets:checking" - ,"" - ]) - (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting (Just t) - ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting (Just t) - ] "" - in showTransaction t) - - ,"showTransaction" ~: do - assertEqual "show a balanced transaction, no eliding" - (unlines - ["2007/01/28 coopportunity" - ," expenses:food:groceries $47.18" - ," assets:checking $-47.18" - ,"" - ]) - (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting (Just t) - ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting (Just t) - ] "" - in showTransactionUnelided t) - - -- document some cases that arise in debug/testing: - ,"showTransaction" ~: do - assertEqual "show an unbalanced transaction, should not elide" - (unlines - ["2007/01/28 coopportunity" - ," expenses:food:groceries $47.18" - ," assets:checking $-47.19" - ,"" - ]) - (showTransaction - (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing - ,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting Nothing - ] "")) - - ,"showTransaction" ~: do - assertEqual "show an unbalanced transaction with one posting, should not elide" - (unlines - ["2007/01/28 coopportunity" - ," expenses:food:groceries $47.18" - ,"" - ]) - (showTransaction - (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing - ] "")) - - ,"showTransaction" ~: do - assertEqual "show a transaction with one posting and a missing amount" - (unlines - ["2007/01/28 coopportunity" - ," expenses:food:groceries " - ,"" - ]) - (showTransaction - (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" - [Posting False "expenses:food:groceries" missingamt "" RegularPosting Nothing - ] "")) - - ,"showTransaction" ~: do - assertEqual "show a transaction with a priced commodityless amount" - (unlines - ["2010/01/01 x" - ," a 1 @ $2" - ," b " - ,"" - ]) - (showTransaction - (txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" - [Posting False "a" (Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])]) "" RegularPosting Nothing - ,Posting False "b" missingamt "" RegularPosting Nothing - ] "")) - - ] diff --git a/Ledger/Types.hs b/Ledger/Types.hs deleted file mode 100644 --- a/Ledger/Types.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-| - -Most data types are defined here to avoid import cycles. -Here is an overview of the hledger data model: - -> Ledger -- hledger's ledger is a journal file plus cached/derived data -> Journal -- a representation of the journal file, containing.. -> [Transaction] -- ..journal transactions, which have date, status, code, description and.. -> [Posting] -- ..two or more account postings (account name and amount) -> Tree AccountName -- all account names as a tree -> Map AccountName Account -- a map from account name to account info (postings and balances) - -For more detailed documentation on each type, see the corresponding modules. - -Terminology has been in flux: - - - ledger 2 had entries containing transactions. - - - hledger 0.4 had Entrys containing RawTransactions, which were flattened to Transactions. - - - ledger 3 has transactions containing postings. - - - hledger 0.5 had LedgerTransactions containing Postings, which were flattened to Transactions. - - - hledger 0.8 has Transactions containing Postings, and no flattened type. - --} - -module Ledger.Types -where -import Ledger.Utils -import qualified Data.Map as Map -import System.Time (ClockTime) -import Data.Typeable (Typeable) - - -type SmartDate = (String,String,String) - -data WhichDate = ActualDate | EffectiveDate deriving (Eq,Show) - -data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord) - -data Interval = NoInterval | Daily | Weekly | Monthly | Quarterly | Yearly - deriving (Eq,Show,Ord) - -type AccountName = String - -data Side = L | R deriving (Eq,Show,Ord) - -data Commodity = Commodity { - symbol :: String, -- ^ the commodity's symbol - -- display preferences for amounts of this commodity - side :: Side, -- ^ should the symbol appear on the left or the right - spaced :: Bool, -- ^ should there be a space between symbol and quantity - comma :: Bool, -- ^ should thousands be comma-separated - precision :: Int -- ^ number of decimal places to display - } deriving (Eq,Show,Ord) - -data Amount = Amount { - commodity :: Commodity, - quantity :: Double, - price :: Maybe MixedAmount -- ^ unit price/conversion rate for this amount at posting time - } deriving (Eq) - -newtype MixedAmount = Mixed [Amount] deriving (Eq) - -data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting - deriving (Eq,Show) - -data Posting = Posting { - pstatus :: Bool, - paccount :: AccountName, - pamount :: MixedAmount, - pcomment :: String, - ptype :: PostingType, - ptransaction :: Maybe Transaction -- ^ this posting's parent transaction (co-recursive types). - -- Tying this knot gets tedious, Maybe makes it easier/optional. - } deriving (Eq) - -data Transaction = Transaction { - tdate :: Day, - teffectivedate :: Maybe Day, - tstatus :: Bool, -- XXX tcleared ? - tcode :: String, - tdescription :: String, - tcomment :: String, - tpostings :: [Posting], - tpreceding_comment_lines :: String - } deriving (Eq) - -data ModifierTransaction = ModifierTransaction { - mtvalueexpr :: String, - mtpostings :: [Posting] - } deriving (Eq) - -data PeriodicTransaction = PeriodicTransaction { - ptperiodicexpr :: String, - ptpostings :: [Posting] - } deriving (Eq) - -data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord) - -data TimeLogEntry = TimeLogEntry { - tlcode :: TimeLogCode, - tldatetime :: LocalTime, - tlcomment :: String - } deriving (Eq,Ord) - -data HistoricalPrice = HistoricalPrice { - hdate :: Day, - hsymbol :: String, - hamount :: MixedAmount - } deriving (Eq) -- & Show (in Amount.hs) - -data Journal = Journal { - jmodifiertxns :: [ModifierTransaction], - jperiodictxns :: [PeriodicTransaction], - jtxns :: [Transaction], - open_timelog_entries :: [TimeLogEntry], - historical_prices :: [HistoricalPrice], - final_comment_lines :: String, - filepath :: FilePath, - filereadtime :: ClockTime, - jtext :: String - } deriving (Eq) - -data Account = Account { - aname :: AccountName, - apostings :: [Posting], -- ^ transactions in this account - abalance :: MixedAmount -- ^ sum of transactions in this account and subaccounts - } - -data Ledger = Ledger { - journal :: Journal, - accountnametree :: Tree AccountName, - accountmap :: Map.Map AccountName Account - } deriving Typeable - --- | A generic, pure specification of how to filter transactions/postings. --- This exists to keep app-specific options out of the hledger library. -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/Ledger/Utils.hs b/Ledger/Utils.hs deleted file mode 100644 --- a/Ledger/Utils.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| - -Provide standard imports and utilities which are useful everywhere, or -needed low in the module hierarchy. This is the bottom of the dependency graph. - --} - -module Ledger.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 Ledger.Utils, -module Text.Printf, -module Text.RegexPR, -module Test.HUnit, -) -where -import Data.Char -import Control.Exception -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 -#if __GLASGOW_HASKELL__ <= 610 -import Prelude hiding (readFile,putStr,print) -import System.IO.UTF8 -#endif -import Test.HUnit -import Text.Printf -import Text.RegexPR -import Text.ParserCombinators.Parsec - - --- 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 ' ' - --- 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 newline and a label prepended -ltrace :: Show a => String -> a -> a -ltrace l a = trace (l ++ ": " ++ show a) a - --- | trace an expression using a custom show function -tracewith f e = trace (f e) e - --- parsing - -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 - -strictReadFile :: FilePath -> IO String -strictReadFile f = readFile f >>= \s -> Control.Exception.evaluate (length s) >> return s diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -1,5 +1,5 @@ name: hledger-lib -version: 0.9 +version: 0.10 category: Finance synopsis: Core types and utilities for working with hledger (or c++ ledger) data. description: @@ -26,21 +26,21 @@ library exposed-modules: - Ledger - Ledger.Account - Ledger.AccountName - Ledger.Amount - Ledger.Commodity - Ledger.Dates - Ledger.IO - Ledger.Transaction - Ledger.Journal - Ledger.Ledger - Ledger.Posting - Ledger.Parse - Ledger.TimeLog - Ledger.Types - Ledger.Utils + Hledger.Data + Hledger.Data.Account + Hledger.Data.AccountName + Hledger.Data.Amount + Hledger.Data.Commodity + Hledger.Data.Dates + Hledger.Data.IO + Hledger.Data.Transaction + Hledger.Data.Journal + Hledger.Data.Ledger + Hledger.Data.Posting + Hledger.Data.Parse + Hledger.Data.TimeLog + Hledger.Data.Types + Hledger.Data.Utils Build-Depends: base >= 3 && < 5 ,containers @@ -51,6 +51,7 @@ ,old-time ,parsec ,regexpr >= 0.5.1 + ,safe >= 0.2 ,time ,utf8-string >= 0.3 ,HUnit