hledger-lib 0.9 → 0.10

raw patch · 31 files changed

+3371/−3355 lines, 31 filesdep +safePVP ok

version bump matches the API change (PVP)

Dependencies added: safe

API changes (from Hackage documentation)

Files

• Hledger/Data.hs +58/−0
• Hledger/Data/Account.hs +27/−0
• Hledger/Data/AccountName.hs +171/−0
• Hledger/Data/Amount.hs +340/−0
• Hledger/Data/Commodity.hs +39/−0
• Hledger/Data/Dates.hs +471/−0
• Hledger/Data/IO.hs +84/−0
• Hledger/Data/Journal.hs +358/−0
• Hledger/Data/Ledger.hs +122/−0
• Hledger/Data/Parse.hs +731/−0
• Hledger/Data/Posting.hs +94/−0
• Hledger/Data/TimeLog.hs +121/−0
• Hledger/Data/Transaction.hs +253/−0
• Hledger/Data/Types.hs +162/−0
• Hledger/Data/Utils.hs +323/−0
• Ledger.hs +0/−58
• Ledger/Account.hs +0/−27
• Ledger/AccountName.hs +0/−171
• Ledger/Amount.hs +0/−340
• Ledger/Commodity.hs +0/−39
• Ledger/Dates.hs +0/−464
• Ledger/IO.hs +0/−99
• Ledger/Journal.hs +0/−321
• Ledger/Ledger.hs +0/−180
• Ledger/Parse.hs +0/−732
• Ledger/Posting.hs +0/−94
• Ledger/TimeLog.hs +0/−90
• Ledger/Transaction.hs +0/−250
• Ledger/Types.hs +0/−153
• Ledger/Utils.hs +0/−321
• hledger-lib.cabal +17/−16

@@ -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+    ]

@@ -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+

@@ -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+

@@ -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]+++  ]

@@ -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+

@@ -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"]++    ]

@@ -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+

@@ -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]

@@ -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

@@ -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] ""++

@@ -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+

@@ -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]++ ]

@@ -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+         ] ""))++  ]

@@ -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)+

@@ -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

@@ -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-    ]

@@ -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-

@@ -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-

@@ -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]---  ]

@@ -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-

@@ -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"]--    ]

@@ -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-

@@ -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]

@@ -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

@@ -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] ""--

@@ -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-

@@ -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-                 ]

@@ -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-         ] ""))--  ]

@@ -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)-

@@ -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

@@ -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