hledger-lib 0.14 → 0.15

raw patch · 25 files changed

+2202/−949 lines, 25 filesdep +cmdargssetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: cmdargs

API changes (from Hackage documentation)

Files

• Hledger.hs +11/−0
• Hledger/Data.hs +9/−7
• Hledger/Data/Account.hs +4/−2
• Hledger/Data/AccountName.hs +25/−2
• Hledger/Data/Amount.hs +247/−287
• Hledger/Data/Commodity.hs +7/−3
• Hledger/Data/Dates.hs +34/−6
• Hledger/Data/Journal.hs +63/−22
• Hledger/Data/Ledger.hs +19/−1
• Hledger/Data/Matching.hs +317/−0
• Hledger/Data/Posting.hs +75/−9
• Hledger/Data/TimeLog.hs +8/−1
• Hledger/Data/Transaction.hs +19/−8
• Hledger/Data/Types.hs +19/−16
• Hledger/Data/UTF8.hs +0/−83
• Hledger/Data/Utils.hs +0/−376
• Hledger/Read.hs +10/−4
• Hledger/Read/JournalReader.hs +186/−101
• Hledger/Read/TimelogReader.hs +7/−4
• Hledger/Read/Utils.hs +17/−6
• Hledger/Reports.hs +595/−0
• Hledger/Utils.hs +427/−0
• Hledger/Utils/UTF8.hs +87/−0
• Setup.hs +0/−2
• hledger-lib.cabal +16/−9

@@ -0,0 +1,11 @@+module Hledger (+                module Hledger.Data+               ,module Hledger.Read+               ,module Hledger.Reports+               ,module Hledger.Utils+)+where+import Hledger.Data+import Hledger.Read+import Hledger.Reports+import Hledger.Utils

@@ -13,28 +13,30 @@                module Hledger.Data.Amount,                module Hledger.Data.Commodity,                module Hledger.Data.Dates,-               module Hledger.Data.Transaction,-               module Hledger.Data.Ledger,                module Hledger.Data.Journal,+               module Hledger.Data.Ledger,+               module Hledger.Data.Matching,                module Hledger.Data.Posting,                module Hledger.Data.TimeLog,+               module Hledger.Data.Transaction,                module Hledger.Data.Types,-               module Hledger.Data.Utils,                tests_Hledger_Data               ) where+import Test.HUnit+ import Hledger.Data.Account import Hledger.Data.AccountName import Hledger.Data.Amount import Hledger.Data.Commodity import Hledger.Data.Dates-import Hledger.Data.Transaction-import Hledger.Data.Ledger import Hledger.Data.Journal+import Hledger.Data.Ledger+import Hledger.Data.Matching import Hledger.Data.Posting import Hledger.Data.TimeLog+import Hledger.Data.Transaction import Hledger.Data.Types-import Hledger.Data.Utils  tests_Hledger_Data = TestList     [@@ -45,9 +47,9 @@     ,tests_Hledger_Data_Dates     ,tests_Hledger_Data_Journal     ,tests_Hledger_Data_Ledger+    ,tests_Hledger_Data_Matching     ,tests_Hledger_Data_Posting     ,tests_Hledger_Data_TimeLog     ,tests_Hledger_Data_Transaction     -- ,tests_Hledger_Data_Types-    -- ,tests_Hledger_Data_Utils     ]

@@ -12,9 +12,11 @@  module Hledger.Data.Account where-import Hledger.Data.Utils-import Hledger.Data.Types+import Test.HUnit+import Text.Printf+ import Hledger.Data.Amount+import Hledger.Data.Types   instance Show Account where

@@ -9,13 +9,18 @@  module Hledger.Data.AccountName where-import Hledger.Data.Utils-import Hledger.Data.Types+import Data.List import Data.Map (Map)+import Data.Tree+import Test.HUnit+import Text.Printf import qualified Data.Map as M +import Hledger.Data.Types+import Hledger.Utils  + -- change to use a different separator for nested accounts acctsepchar = ':' @@ -172,6 +177,24 @@  clipAccountName :: Int -> AccountName -> AccountName clipAccountName n = accountNameFromComponents . take n . accountNameComponents++-- | Convert an account name to a regular expression matching it and its subaccounts.+accountNameToAccountRegex :: String -> String+accountNameToAccountRegex "" = ""+accountNameToAccountRegex a = printf "^%s(:|$)" a++-- | Convert an account name to a regular expression matching it and its subaccounts.+accountNameToAccountOnlyRegex :: String -> String+accountNameToAccountOnlyRegex "" = ""+accountNameToAccountOnlyRegex a = printf "^%s$" a++-- | Convert an exact account-matching regular expression to a plain account name.+accountRegexToAccountName :: String -> String+accountRegexToAccountName = regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1"++-- | Does this string look like an exact account-matching regular expression ?+isAccountRegex  :: String -> Bool+isAccountRegex s = take 1 s == "^" && (take 5 $ reverse s) == ")$|:("  tests_Hledger_Data_AccountName = TestList  [

@@ -1,8 +1,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-|-An 'Amount' is some quantity of money, shares, or anything else.--A simple amount is a 'Commodity', quantity pair:+A simple 'Amount' is some quantity of money, shares, or anything else.+It has a (possibly null) 'Commodity' and a numeric quantity:  @   $1 @@ -14,116 +13,121 @@   0  @ -An amount may also have a per-unit price, or conversion rate, in terms-of some other commodity. If present, this is displayed after \@:+It may also have an assigned 'Price', representing this amount's per-unit+or total cost in a different commodity. If present, this is rendered like+so:  @-  EUR 3 \@ $1.35+  EUR 2 \@ $1.50  (unit price)+  EUR 2 \@\@ $3   (total price) @ -A 'MixedAmount' is zero or more simple amounts.  Mixed amounts are-usually normalised so that there is no more than one amount in each-commodity, and no zero amounts (or, there is just a single zero amount-and no others.):+A 'MixedAmount' is zero or more simple amounts, so can represent multiple+commodities; this is the type most often used:  @+  0   $50 + EUR 3   16h + $13.55 + AAPL 500 + 6 oranges-  0 @ -We can do limited arithmetic with simple or mixed amounts: either-price-preserving arithmetic with similarly-priced amounts, or-price-discarding arithmetic which ignores and discards prices.+When a mixed amount has been \"normalised\", it has no more than one amount+in each commodity and no zero amounts; or it has just a single zero amount+and no others. --}+Limited arithmetic with simple and mixed amounts is supported, best used+with similar amounts since it mostly ignores assigned prices and commodity+exchange rates. --- XXX due for review/rewrite+-}  module Hledger.Data.Amount (-                            amounts,-                            canonicaliseAmount,-                            canonicaliseMixedAmount,-                            convertMixedAmountToSimilarCommodity,-                            costOfAmount,-                            costOfMixedAmount,-                            divideAmount,-                            divideMixedAmount,-                            isNegativeMixedAmount,-                            isReallyZeroMixedAmountCost,-                            isZeroMixedAmount,-                            maxprecision,-                            maxprecisionwithpoint,-                            missingamt,-                            normaliseMixedAmount,-                            nullamt,-                            nullmixedamt,-                            punctuatethousands,-                            setAmountPrecision,-                            setMixedAmountPrecision,-                            showAmountDebug,-                            showMixedAmount,-                            showMixedAmountDebug,-                            showMixedAmountOrZero,-                            showMixedAmountOrZeroWithoutPrice,-                            showMixedAmountWithoutPrice,-                            showMixedAmountWithPrecision,-                            sumMixedAmountsPreservingHighestPrecision,-                            tests_Hledger_Data_Amount-                            -- Hledger.Data.Amount.tests_Hledger_Data_Amount-                           )-where-import qualified Data.Map as Map+  -- * Amount+  nullamt,+  amountWithCommodity,+  canonicaliseAmountCommodity,+  setAmountPrecision,+  -- ** arithmetic+  costOfAmount,+  divideAmount,+  -- ** rendering+  showAmount,+  showAmountDebug,+  showAmountWithoutPrice,+  maxprecision,+  maxprecisionwithpoint,+  -- * MixedAmount+  nullmixedamt,+  missingamt,+  amounts,+  normaliseMixedAmount,+  canonicaliseMixedAmountCommodity,+  mixedAmountWithCommodity,+  setMixedAmountPrecision,+  -- ** arithmetic+  costOfMixedAmount,+  divideMixedAmount,+  isNegativeMixedAmount,+  isZeroMixedAmount,+  isReallyZeroMixedAmountCost,+  -- ** rendering+  showMixedAmount,+  showMixedAmountDebug,+  showMixedAmountWithoutPrice,+  showMixedAmountWithPrecision,+  -- * misc.+  tests_Hledger_Data_Amount+) where++import Data.Char (isDigit)+import Data.List import Data.Map (findWithDefault)+import Test.HUnit+import Text.Printf+import qualified Data.Map as Map -import Hledger.Data.Utils import Hledger.Data.Types import Hledger.Data.Commodity+import Hledger.Utils  -instance Show Amount where show = showAmount-instance Show MixedAmount where show = showMixedAmount deriving instance Show HistoricalPrice +-------------------------------------------------------------------------------+-- Amount++instance Show Amount where show = showAmount+ instance Num Amount where     abs (Amount c q p) = Amount c (abs q) p     signum (Amount c q p) = Amount c (signum q) p     fromInteger i = Amount (comm "") (fromInteger i) Nothing+    negate a@Amount{quantity=q} = a{quantity=(-q)}     (+) = similarAmountsOp (+)     (-) = similarAmountsOp (-)     (*) = similarAmountsOp (*) -instance Num MixedAmount where-    fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing]-    negate (Mixed as) = Mixed $ map negateAmountPreservingPrice as-        where negateAmountPreservingPrice a = (-a){price=price a}-    (+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs-    (*)    = error' "programming error, mixed amounts do not support multiplication"-    abs    = error' "programming error, mixed amounts do not support abs"-    signum = error' "programming error, mixed amounts do not support signum"+-- | The empty simple amount.+nullamt :: Amount+nullamt = Amount unknown 0 Nothing --- | Apply a binary arithmetic operator to two amounts, after converting--- the first to the commodity (and display precision) of the second in a--- simplistic way. This should be used only for two amounts in the same--- commodity, since the conversion rate is assumed to be 1.--- NB preserving the second commodity is preferred since sum and other--- folds start with the no-commodity zero amount.+-- | Apply a binary arithmetic operator to two amounts, ignoring and+-- discarding any assigned prices, and converting the first to the+-- commodity of the second in a simplistic way (1-1 exchange rate).+-- The highest precision of either amount is preserved in the result. similarAmountsOp :: (Double -> Double -> Double) -> Amount -> Amount -> Amount-similarAmountsOp op a (Amount bc bq _) =-    Amount bc (quantity (convertAmountToSimilarCommodity bc a) `op` bq) Nothing---- | Convert an amount to the specified commodity, assuming an exchange rate of 1.-convertAmountToSimilarCommodity :: Commodity -> Amount -> Amount-convertAmountToSimilarCommodity c (Amount _ q _) = Amount c q Nothing+similarAmountsOp op a@(Amount Commodity{precision=ap} _ _) (Amount bc@Commodity{precision=bp} bq _) =+    Amount bc{precision=max ap bp} (quantity (amountWithCommodity bc a) `op` bq) Nothing --- | Convert a mixed amount to the specified commodity, assuming an exchange rate of 1.-convertMixedAmountToSimilarCommodity :: Commodity -> MixedAmount -> Amount-convertMixedAmountToSimilarCommodity c (Mixed as) = Amount c total Nothing-    where-      total = sum $ map (quantity . convertAmountToSimilarCommodity c) as+-- | Convert an amount to the specified commodity, ignoring and discarding+-- any assigned prices and assuming an exchange rate of 1.+amountWithCommodity :: Commodity -> Amount -> Amount+amountWithCommodity c (Amount _ q _) = Amount c q Nothing --- | Convert an amount to the commodity of its saved price, if any.  Notes:+-- | Convert an amount to the commodity of its assigned price, if any.  Notes:+-- -- - price amounts must be MixedAmounts with exactly one component Amount (or there will be a runtime error)+-- -- - price amounts should be positive, though this is not currently enforced costOfAmount :: Amount -> Amount costOfAmount a@(Amount _ q price) =@@ -133,14 +137,33 @@       Just (TotalPrice (Mixed [Amount pc pq Nothing])) -> Amount pc (pq*signum q) Nothing       _ -> error' "costOfAmount: Malformed price encountered, programmer error" +-- | Divide an amount's quantity by a constant.+divideAmount :: Amount -> Double -> Amount+divideAmount a@Amount{quantity=q} d = a{quantity=q/d}++-- | Is this amount negative ? The price is ignored.+isNegativeAmount :: Amount -> Bool+isNegativeAmount Amount{quantity=q} = q < 0++-- | Does this amount appear to be zero when displayed with its given precision ?+isZeroAmount :: Amount -> Bool+isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPriceOrCommodity++-- | Is this amount "really" zero, regardless of the display precision ?+-- Since we are using floating point, for now just test to some high precision.+isReallyZeroAmount :: Amount -> Bool+isReallyZeroAmount = null . filter (`elem` "123456789") . printf ("%."++show zeroprecision++"f") . quantity+    where zeroprecision = 8+ -- | Get the string representation of an amount, based on its commodity's -- display settings except using the specified precision. showAmountWithPrecision :: Int -> Amount -> String showAmountWithPrecision p = showAmount . setAmountPrecision p +-- | Set the display precision in the amount's commodity.+setAmountPrecision :: Int -> Amount -> Amount setAmountPrecision p a@Amount{commodity=c} = a{commodity=c{precision=p}} --- XXX refactor -- | Get the unambiguous string representation of an amount, for debugging. showAmountDebug :: Amount -> String showAmountDebug (Amount c q pri) = printf "Amount {commodity = %s, quantity = %s, price = %s}"@@ -163,7 +186,8 @@ showPriceDebug (TotalPrice pa) = " @@ " ++ showMixedAmountDebug pa  -- | Get the string representation of an amount, based on its commodity's--- display settings. Amounts which look like zero are rendered without sign or commodity.+-- display settings. String representations equivalent to zero are+-- converted to just \"0\". showAmount :: Amount -> String showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = "" -- can appear in an error message showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) _ pri) =@@ -190,15 +214,6 @@          | p == maxprecision             = chopdotzero $ printf "%f" q          | otherwise                    = printf ("%."++show p++"f") q -chopdotzero str = reverse $ case reverse str of-                              '0':'.':s -> s-                              s         -> s---- | A special precision value meaning show all available digits.-maxprecision = 999998--- | Similar, forces display of a decimal point.-maxprecisionwithpoint = 999999- -- | Replace a number string's decimal point with the specified character, -- and add the specified digit group separators. punctuatenumber :: Char -> Char -> [Int] -> String -> String@@ -217,35 +232,89 @@           | otherwise = let (s,rest) = splitAt g str                         in s ++ [sep] ++ addseps sep gs rest --- | Add thousands-separating commas to a decimal number string-punctuatethousands :: String -> String-punctuatethousands s =-    sign ++ addcommas int ++ frac-    where -      (sign,num) = break isDigit s-      (int,frac) = break (=='.') num-      addcommas = reverse . concat . intersperse "," . triples . reverse-      triples [] = []-      triples l  = take 3 l : triples (drop 3 l)+chopdotzero str = reverse $ case reverse str of+                              '0':'.':s -> s+                              s         -> s --- | Does this amount appear to be zero when displayed with its given precision ?-isZeroAmount :: Amount -> Bool-isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPriceOrCommodity+-- | For rendering: a special precision value which means show all available digits.+maxprecision :: Int+maxprecision = 999998 --- | Is this amount "really" zero, regardless of the display precision ?--- Since we are using floating point, for now just test to some high precision.-isReallyZeroAmount :: Amount -> Bool-isReallyZeroAmount = null . filter (`elem` "123456789") . printf ("%."++show zeroprecision++"f") . quantity-    where zeroprecision = 8+-- | For rendering: a special precision value which forces display of a decimal point.+maxprecisionwithpoint :: Int+maxprecisionwithpoint = 999999 --- | Is this amount negative ? The price is ignored.-isNegativeAmount :: Amount -> Bool-isNegativeAmount Amount{quantity=q} = q < 0+-- | Replace an amount's commodity with the canonicalised version from+-- the provided commodity map.+canonicaliseAmountCommodity :: Maybe (Map.Map String Commodity) -> Amount -> Amount+canonicaliseAmountCommodity Nothing                      = id+canonicaliseAmountCommodity (Just canonicalcommoditymap) = fixamount+    where+      -- like journalCanonicaliseAmounts+      fixamount a@Amount{commodity=c} = a{commodity=fixcommodity c}+      fixcommodity c@Commodity{symbol=s} = findWithDefault c s canonicalcommoditymap --- | Access a mixed amount's components.+-------------------------------------------------------------------------------+-- MixedAmount++instance Show MixedAmount where show = showMixedAmount++instance Num MixedAmount where+    fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing]+    negate (Mixed as) = Mixed $ map negate as+    (+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs+    (*)    = error' "programming error, mixed amounts do not support multiplication"+    abs    = error' "programming error, mixed amounts do not support abs"+    signum = error' "programming error, mixed amounts do not support signum"++-- | The empty mixed amount.+nullmixedamt :: MixedAmount+nullmixedamt = Mixed []++-- | A temporary value for parsed transactions which had no amount specified.+missingamt :: MixedAmount+missingamt = Mixed [Amount unknown{symbol="AUTO"} 0 Nothing]++-- | Simplify a mixed amount by removing redundancy in its component amounts,+-- as follows:+--+-- 1. combine amounts which have the same commodity, discarding all but the first's price.+--+-- 2. remove zero amounts+--+-- 3. if there are no amounts at all, add a single zero amount+normaliseMixedAmount :: MixedAmount -> MixedAmount+normaliseMixedAmount (Mixed as) = Mixed as''+    where +      as'' = if null nonzeros then [nullamt] else nonzeros+      (_,nonzeros) = partition (\a -> isReallyZeroAmount a && Mixed [a] /= missingamt) as'+      as' = map sumAmountsDiscardingAllButFirstPrice $ group $ sort as+      sort = sortBy (\a1 a2 -> compare (sym a1) (sym a2))+      group = groupBy (\a1 a2 -> sym a1 == sym a2)+      sym = symbol . commodity++sumAmountsDiscardingAllButFirstPrice [] = nullamt+sumAmountsDiscardingAllButFirstPrice as = (sum as){price=price $ head as}++-- | Get a mixed amount's component amounts. amounts :: MixedAmount -> [Amount] amounts (Mixed as) = as +-- | Convert a mixed amount's component amounts to the commodity of their+-- assigned price, if any.+costOfMixedAmount :: MixedAmount -> MixedAmount+costOfMixedAmount (Mixed as) = Mixed $ map costOfAmount as++-- | Divide a mixed amount's quantities by a constant.+divideMixedAmount :: MixedAmount -> Double -> MixedAmount+divideMixedAmount (Mixed as) d = Mixed $ map (flip divideAmount d) as++-- | Is this mixed amount negative, if it can be normalised to a single commodity ?+isNegativeMixedAmount :: MixedAmount -> Maybe Bool+isNegativeMixedAmount m = case as of [a] -> Just $ isNegativeAmount a+                                     _   -> Nothing+    where as = amounts $ normaliseMixedAmount m+ -- | Does this mixed amount appear to be zero when displayed with its given precision ? isZeroMixedAmount :: MixedAmount -> Bool isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmount@@ -254,22 +323,20 @@ isReallyZeroMixedAmount :: MixedAmount -> Bool isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmount --- | Is this mixed amount negative, if it can be normalised to a single commodity ?-isNegativeMixedAmount :: MixedAmount -> Maybe Bool-isNegativeMixedAmount m = case as of [a] -> Just $ isNegativeAmount a-                                     _   -> Nothing-    where-      as = amounts $ normaliseMixedAmount m- -- | Is this mixed amount "really" zero, after converting to cost -- commodities where possible ? isReallyZeroMixedAmountCost :: MixedAmount -> Bool isReallyZeroMixedAmountCost = isReallyZeroMixedAmount . costOfMixedAmount --- -- | MixedAmount derives Eq in Types.hs, but that doesn't know that we--- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code in there.--- -- When zero equality is important, use this, for now; should be used--- -- everywhere.+-- -- | Convert a mixed amount to the specified commodity, assuming an exchange rate of 1.+mixedAmountWithCommodity :: Commodity -> MixedAmount -> Amount+mixedAmountWithCommodity c (Mixed as) = Amount c total Nothing+    where+      total = sum $ map (quantity . amountWithCommodity c) as++-- -- | MixedAmount derived Eq instance in Types.hs doesn't know that we+-- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code over there.+-- -- For now, use this when cross-commodity zero equality is important. -- mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool -- mixedAmountEquals a b = amounts a' == amounts b' || (isZeroMixedAmount a' && isZeroMixedAmount b') --     where a' = normaliseMixedAmount a@@ -281,13 +348,13 @@ showMixedAmount :: MixedAmount -> String showMixedAmount m = vConcatRightAligned $ map show $ amounts $ normaliseMixedAmount m +-- | Set the display precision in the amount's commodities. setMixedAmountPrecision :: Int -> MixedAmount -> MixedAmount setMixedAmountPrecision p (Mixed as) = Mixed $ map (setAmountPrecision p) as  -- | Get the string representation of a mixed amount, showing each of its -- component amounts with the specified precision, ignoring their--- commoditys' display precision settings. NB a mixed amount can have an--- empty amounts list in which case it shows as \"\".+-- commoditys' display precision settings. showMixedAmountWithPrecision :: Int -> MixedAmount -> String showMixedAmountWithPrecision p m =     vConcatRightAligned $ map (showAmountWithPrecision p) $ amounts $ normaliseMixedAmount m@@ -302,169 +369,70 @@ showMixedAmountWithoutPrice :: MixedAmount -> String showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth as     where-      (Mixed as) = normaliseMixedAmountIgnoringPrice m+      (Mixed as) = normaliseMixedAmount $ stripPrices m+      stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{price=Nothing}       width = maximum $ map (length . show) as       showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice --- | Get the string representation of a mixed amount, and if it--- appears to be all zero just show a bare 0, ledger-style.-showMixedAmountOrZero :: MixedAmount -> String-showMixedAmountOrZero a | a == missingamt = ""-                        | isZeroMixedAmount a = "0"-                        | otherwise = showMixedAmount a---- | Get the string representation of a mixed amount, or a bare 0,--- without any \@ prices.-showMixedAmountOrZeroWithoutPrice :: MixedAmount -> String-showMixedAmountOrZeroWithoutPrice a-    | isZeroMixedAmount a = "0"-    | otherwise = showMixedAmountWithoutPrice a---- | Simplify a mixed amount by removing redundancy in its component amounts, as follows:--- 1. sum amounts which have the same commodity (ignoring their price)--- 2. remove zero amounts--- 3. if there are no amounts at all, add a single zero amount-normaliseMixedAmount :: MixedAmount -> MixedAmount-normaliseMixedAmount (Mixed as) = Mixed as''-    where -      as'' = if null nonzeros then [nullamt] else nonzeros-      (_,nonzeros) = partition (\a -> isReallyZeroAmount a && Mixed [a] /= missingamt) as'-      as' = map sumSamePricedAmountsPreservingPrice $ group $ sort as-      sort = sortBy (\a1 a2 -> compare (sym a1) (sym a2))-      group = groupBy (\a1 a2 -> sym a1 == sym a2)-      sym = symbol . commodity---- | Set a mixed amount's commodity to the canonicalised commodity from--- the provided commodity map.-canonicaliseMixedAmount :: Maybe (Map.Map String Commodity) -> MixedAmount -> MixedAmount-canonicaliseMixedAmount canonicalcommoditymap (Mixed as) = Mixed $ map (canonicaliseAmount canonicalcommoditymap) as---- | Set an amount's commodity to the canonicalised commodity from+-- | Replace a mixed amount's commodity with the canonicalised version from -- the provided commodity map.-canonicaliseAmount :: Maybe (Map.Map String Commodity) -> Amount -> Amount-canonicaliseAmount Nothing                      = id-canonicaliseAmount (Just canonicalcommoditymap) = fixamount-    where-      -- like journalCanonicaliseAmounts-      fixamount a@Amount{commodity=c} = a{commodity=fixcommodity c}-      fixcommodity c@Commodity{symbol=s} = findWithDefault c s canonicalcommoditymap---- various sum variants..--sumAmountsDiscardingPrice [] = nullamt-sumAmountsDiscardingPrice as = (sum as){price=Nothing}--sumSamePricedAmountsPreservingPrice [] = nullamt-sumSamePricedAmountsPreservingPrice as = (sum as){price=price $ head as}---- | Simplify a mixed amount by combining any component amounts which have--- the same commodity, ignoring and discarding their unit prices if any.--- Also removes zero amounts, or adds a single zero amount if there are no--- amounts at all.-normaliseMixedAmountIgnoringPrice :: MixedAmount -> MixedAmount-normaliseMixedAmountIgnoringPrice (Mixed as) = Mixed as''-    where-      as'' = map sumAmountsDiscardingPrice $ group $ sort as'-      group = groupBy samesymbol where samesymbol a1 a2 = sym a1 == sym a2-      sort = sortBy (comparing sym)-      sym = symbol . commodity-      as' | null nonzeros = [head $ zeros ++ [nullamt]]-          | otherwise = nonzeros-          where (zeros,nonzeros) = partition isZeroAmount as--sumMixedAmountsPreservingHighestPrecision :: [MixedAmount] -> MixedAmount-sumMixedAmountsPreservingHighestPrecision ms = foldl' (+~) 0 ms-    where (+~) (Mixed as) (Mixed bs) = normaliseMixedAmountPreservingHighestPrecision $ Mixed $ as ++ bs--normaliseMixedAmountPreservingHighestPrecision :: MixedAmount -> MixedAmount-normaliseMixedAmountPreservingHighestPrecision (Mixed as) = Mixed as''-    where-      as'' = map sumSamePricedAmountsPreservingPriceAndHighestPrecision $ group $ sort as'-      sort = sortBy cmpsymbolandprice-      cmpsymbolandprice a1 a2 = compare (sym a1,price a1) (sym a2,price a2)-      group = groupBy samesymbolandprice-      samesymbolandprice a1 a2 = (sym a1 == sym a2) && (price a1 == price a2)-      sym = symbol . commodity-      as' | null nonzeros = [head $ zeros ++ [nullamt]]-          | otherwise = nonzeros-      (zeros,nonzeros) = partition isReallyZeroAmount as--sumSamePricedAmountsPreservingPriceAndHighestPrecision [] = nullamt-sumSamePricedAmountsPreservingPriceAndHighestPrecision as = (sumAmountsPreservingHighestPrecision as){price=price $ head as}--sumAmountsPreservingHighestPrecision :: [Amount] -> Amount-sumAmountsPreservingHighestPrecision as = foldl' (+~) 0 as-    where (+~) = amountopPreservingHighestPrecision (+)--amountopPreservingHighestPrecision :: (Double -> Double -> Double) -> Amount -> Amount -> Amount-amountopPreservingHighestPrecision op a@(Amount ac@Commodity{precision=ap} _ _) (Amount bc@Commodity{precision=bp} bq _) = -    Amount c q Nothing-    where-      q = quantity (convertAmountToSimilarCommodity bc a) `op` bq-      c = if ap > bp then ac else bc------- | Convert a mixed amount's component amounts to the commodity of their--- saved price, if any.-costOfMixedAmount :: MixedAmount -> MixedAmount-costOfMixedAmount (Mixed as) = Mixed $ map costOfAmount as---- | Divide a mixed amount's quantities by some constant.-divideMixedAmount :: MixedAmount -> Double -> MixedAmount-divideMixedAmount (Mixed as) d = Mixed $ map (flip divideAmount d) as---- | Divide an amount's quantity by some constant.-divideAmount :: Amount -> Double -> Amount-divideAmount a@Amount{quantity=q} d = a{quantity=q/d}---- | The empty simple amount.-nullamt :: Amount-nullamt = Amount unknown 0 Nothing---- | The empty mixed amount.-nullmixedamt :: MixedAmount-nullmixedamt = Mixed []---- | A temporary value for parsed transactions which had no amount specified.-missingamt :: MixedAmount-missingamt = Mixed [Amount unknown{symbol="AUTO"} 0 Nothing]+canonicaliseMixedAmountCommodity :: Maybe (Map.Map String Commodity) -> MixedAmount -> MixedAmount+canonicaliseMixedAmountCommodity canonicalcommoditymap (Mixed as) = Mixed $ map (canonicaliseAmountCommodity canonicalcommoditymap) as +-------------------------------------------------------------------------------+-- misc  tests_Hledger_Data_Amount = TestList [ -   "showAmount" ~: do-     showAmount (dollars 0 + pounds 0) `is` "0"+  -- Amount -  ,"showMixedAmount" ~: do-     showMixedAmount (Mixed [Amount dollar 0 Nothing]) `is` "0"-     showMixedAmount (Mixed []) `is` "0"-     showMixedAmount missingamt `is` ""+   "costOfAmount" ~: do+    costOfAmount (euros 1) `is` euros 1+    costOfAmount (euros 2){price=Just $ UnitPrice $ Mixed [dollars 2]} `is` dollars 4+    costOfAmount (euros 1){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars 2+    costOfAmount (euros (-1)){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars (-2) -  ,"showMixedAmountOrZero" ~: do-     showMixedAmountOrZero (Mixed [Amount dollar 0 Nothing]) `is` "0"-     showMixedAmountOrZero (Mixed []) `is` "0"-     showMixedAmountOrZero missingamt `is` ""+  ,"isZeroAmount" ~: do+    assertBool "" $ isZeroAmount $ Amount unknown 0 Nothing+    assertBool "" $ isZeroAmount $ dollars 0 -  ,"amount arithmetic" ~: do+  ,"negating amounts" ~: do+    let a = dollars 1+    negate a `is` a{quantity=(-1)}+    let b = (dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}+    negate b `is` b{quantity=(-1)}++  ,"adding amounts" ~: do     let a1 = dollars 1.23-    let a2 = Amount (comm "$") (-1.23) Nothing-    let a3 = Amount (comm "$") (-1.23) Nothing+    let a2 = dollars (-1.23)+    let a3 = dollars (-1.23)     (a1 + a2) `is` Amount (comm "$") 0 Nothing     (a1 + a3) `is` Amount (comm "$") 0 Nothing     (a2 + a3) `is` Amount (comm "$") (-2.46) Nothing     (a3 + a3) `is` Amount (comm "$") (-2.46) Nothing-    -- arithmetic with different commodities currently assumes conversion rate 1:-    let a4 = euros (-1.23)-    assertBool "" $ isZeroAmount (a1 + a4)--    sum [a2,a3] `is` Amount (comm "$") (-2.46) Nothing-    sum [a3,a3] `is` Amount (comm "$") (-2.46) Nothing     sum [a1,a2,a3,-a3] `is` Amount (comm "$") 0 Nothing-    let dollar0 = dollar{precision=0}-    (sum [Amount dollar 1.25 Nothing, Amount dollar0 (-1) Nothing, Amount dollar (-0.25) Nothing])-      `is` (Amount dollar 0 Nothing)+    -- highest precision is preserved+    let ap1 = (dollars 1){commodity=dollar{precision=1}}+        ap3 = (dollars 1){commodity=dollar{precision=3}}+    (sum [ap1,ap3]) `is` ap3{quantity=2}+    (sum [ap3,ap1]) `is` ap3{quantity=2}+    -- adding different commodities assumes conversion rate 1+    assertBool "" $ isZeroAmount (a1 - euros 1.23) -  ,"mixed amount arithmetic" ~: do+  ,"showAmount" ~: do+    showAmount (dollars 0 + pounds 0) `is` "0"++  -- MixedAmount++  ,"normaliseMixedAmount" ~: do+    normaliseMixedAmount (Mixed []) `is` Mixed [nullamt]+    assertBool "" $ isZeroMixedAmount $ normaliseMixedAmount (Mixed [Amount {commodity=dollar, quantity=10,    price=Nothing}+                                                                    ,Amount {commodity=dollar, quantity=10,    price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))}+                                                                    ,Amount {commodity=dollar, quantity=(-10), price=Nothing}+                                                                    ,Amount {commodity=dollar, quantity=(-10), price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))}+                                                                    ])++  ,"adding mixed amounts" ~: do     let dollar0 = dollar{precision=0}     (sum $ map (Mixed . (\a -> [a]))              [Amount dollar 1.25 Nothing,@@ -472,24 +440,16 @@               Amount dollar (-0.25) Nothing])       `is` Mixed [Amount unknown 0 Nothing] -  ,"normaliseMixedAmount" ~: do-     normaliseMixedAmount (Mixed []) `is` Mixed [nullamt]-     assertBool "" $ isZeroMixedAmount $ normaliseMixedAmount (Mixed [Amount {commodity=dollar, quantity=10,    price=Nothing}-                                                                     ,Amount {commodity=dollar, quantity=10,    price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))}-                                                                     ,Amount {commodity=dollar, quantity=(-10), price=Nothing}-                                                                     ,Amount {commodity=dollar, quantity=(-10), price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))}-                                                                     ])--  ,"punctuatethousands 1" ~: punctuatethousands "" `is` ""--  ,"punctuatethousands 2" ~: punctuatethousands "1234567.8901" `is` "1,234,567.8901"--  ,"punctuatethousands 3" ~: punctuatethousands "-100" `is` "-100"+  ,"showMixedAmount" ~: do+    showMixedAmount (Mixed [dollars 1]) `is` "$1.00"+    showMixedAmount (Mixed [(dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}]) `is` "$1.00 @ €2.00"+    showMixedAmount (Mixed [dollars 0]) `is` "0"+    showMixedAmount (Mixed []) `is` "0"+    showMixedAmount missingamt `is` "" -  ,"costOfAmount" ~: do-    costOfAmount (euros 1) `is` euros 1-    costOfAmount (euros 2){price=Just $ UnitPrice $ Mixed [dollars 2]} `is` dollars 4-    costOfAmount (euros 1){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars 2-    costOfAmount (euros (-1)){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars (-2)+  ,"showMixedAmountWithoutPrice" ~: do+    let a = (dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}+    showMixedAmountWithoutPrice (Mixed [a]) `is` "$1.00"+    showMixedAmountWithoutPrice (Mixed [a, (-a)]) `is` "0"    ]

@@ -8,10 +8,14 @@ -} module Hledger.Data.Commodity where-import Hledger.Data.Utils-import Hledger.Data.Types-import qualified Data.Map as Map+import Data.List import Data.Map ((!))+import Data.Maybe+import Test.HUnit+import qualified Data.Map as Map++import Hledger.Data.Types+import Hledger.Utils   nonsimplecommoditychars = "0123456789-.@;\n \""

@@ -23,13 +23,22 @@ module Hledger.Data.Dates where +import Control.Monad+import Data.List+import Data.Maybe import Data.Time.Format+import Data.Time.Calendar import Data.Time.Calendar.OrdinalDate+import Data.Time.Clock+import Data.Time.LocalTime import Safe (readMay) import System.Locale (defaultTimeLocale)+import Test.HUnit import Text.ParserCombinators.Parsec+import Text.Printf+ import Hledger.Data.Types-import Hledger.Data.Utils+import Hledger.Utils   showDate :: Day -> String@@ -41,6 +50,12 @@     t <- getZonedTime     return $ localDay (zonedTimeToLocalTime t) +-- | Get the current local month number.+getCurrentMonth :: IO Int+getCurrentMonth = do+  (_,m,_) <- toGregorian `fmap` getCurrentDay+  return m+ -- | Get the current local year. getCurrentYear :: IO Integer getCurrentYear = do@@ -106,6 +121,9 @@ parsePeriodExpr :: Day -> String -> Either ParseError (Interval, DateSpan) parsePeriodExpr refdate = parsewith (periodexpr refdate) +maybePeriod :: Day -> String -> Maybe (Interval,DateSpan)+maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate+ -- | Show a DateSpan as a human-readable pseudo-period-expression string. dateSpanAsText :: DateSpan -> String dateSpanAsText (DateSpan Nothing Nothing)   = "all"@@ -157,14 +175,20 @@ -- | Convert a smart date string to an explicit yyyy\/mm\/dd string using -- the provided reference date, or raise an error. fixSmartDateStr :: Day -> String -> String-fixSmartDateStr t s = either parseerror id $ fixSmartDateStrEither t s+fixSmartDateStr d s = either+                       (\e->error' $ printf "could not parse date %s %s" (show s) (show e))+                       id+                       $ fixSmartDateStrEither d s  -- | A safe version of fixSmartDateStr. fixSmartDateStrEither :: Day -> String -> Either ParseError String-fixSmartDateStrEither t s = case parsewith smartdateonly (lowercase s) of-                              Right sd -> Right $ showDay $ fixSmartDate t sd-                              Left e -> Left e+fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d +fixSmartDateStrEither' :: Day -> String -> Either ParseError Day+fixSmartDateStrEither' d s = case parsewith smartdateonly (lowercase s) of+                               Right sd -> Right $ fixSmartDate d sd+                               Left e -> Left e+ -- | Convert a SmartDate to an absolute date using the provided reference date. fixSmartDate :: Day -> SmartDate -> Day fixSmartDate refdate sdate = fix sdate@@ -537,12 +561,16 @@   d <- smartdate   return $ spanFromSmartDate rdate d +-- | Make a datespan from two valid date strings parseable by parsedate+-- (or raise an error). Eg: mkdatespan \"2011/1/1\" \"2011/12/31\". mkdatespan :: String -> String -> DateSpan mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate +nulldatespan :: DateSpan nulldatespan = DateSpan Nothing Nothing -nulldate = parsedate "1900/01/01"+nulldate :: Day+nulldate = parsedate "0000/00/00"  tests_Hledger_Data_Dates = TestList  [

@@ -8,11 +8,19 @@  module Hledger.Data.Journal where-import qualified Data.Map as Map+import Data.List import Data.Map (findWithDefault, (!))+import Data.Ord+import Data.Time.Calendar+import Data.Time.LocalTime+import Data.Tree import Safe (headDef) import System.Time (ClockTime(TOD))-import Hledger.Data.Utils+import Test.HUnit+import Text.Printf+import qualified Data.Map as Map++import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName import Hledger.Data.Amount@@ -21,6 +29,7 @@ import Hledger.Data.Transaction (journalTransactionWithDate,balanceTransaction) import Hledger.Data.Posting import Hledger.Data.TimeLog+import Hledger.Data.Matching   instance Show Journal where@@ -34,6 +43,18 @@              -- ++ (show $ journalTransactions l)              where accounts = flatten $ journalAccountNameTree j +showJournalDebug j = unlines [+                      show j+                     ,show (jtxns j)+                     ,show (jmodifiertxns j)+                     ,show (jperiodictxns j)+                     ,show $ open_timelog_entries j+                     ,show $ historical_prices j+                     ,show $ final_comment_lines j+                     ,show $ jContext j+                     ,show $ map fst $ files j+                     ]+ nulljournal :: Journal nulljournal = Journal { jmodifiertxns = []                       , jperiodictxns = []@@ -47,17 +68,16 @@                       }  nullctx :: JournalContext-nullctx = Ctx { ctxYear = Nothing, ctxCommodity = Nothing, ctxAccount = [] }+nullctx = Ctx { ctxYear = Nothing, ctxCommodity = Nothing, ctxAccount = [], ctxAliases = [] } +nullfilterspec :: FilterSpec nullfilterspec = FilterSpec {      datespan=nulldatespan     ,cleared=Nothing     ,real=False     ,empty=False-    ,costbasis=False     ,acctpats=[]     ,descpats=[]-    ,whichdate=ActualDate     ,depth=Nothing     } @@ -89,7 +109,7 @@ journalPostings = concatMap tpostings . jtxns  journalAccountNamesUsed :: Journal -> [AccountName]-journalAccountNamesUsed = accountNamesFromPostings . journalPostings+journalAccountNamesUsed = sort . accountNamesFromPostings . journalPostings  journalAccountNames :: Journal -> [AccountName] journalAccountNames = sort . expandAccountNames . journalAccountNamesUsed@@ -100,38 +120,49 @@ -- Various kinds of filtering on journals. We do it differently depending -- on the command. --- | Keep only transactions we are interested in, as described by--- the filter specification. May also massage the data a little.+-------------------------------------------------------------------------------+-- filtering V2++-- | Keep only postings matching the query expression.+-- This can leave unbalanced transactions.+filterJournalPostings2 :: Matcher -> Journal -> Journal+filterJournalPostings2 m j@Journal{jtxns=ts} = j{jtxns=map filtertransactionpostings ts}+    where+      filtertransactionpostings t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps}++-- | Keep only transactions matching the query expression.+filterJournalTransactions2 :: Matcher -> Journal -> Journal+filterJournalTransactions2 m j@Journal{jtxns=ts} = j{jtxns=filter (m `matchesTransaction`) ts}++-------------------------------------------------------------------------------+-- filtering V1++-- | Keep only transactions we are interested in, as described by the+-- filter specification. filterJournalTransactions :: FilterSpec -> Journal -> Journal filterJournalTransactions FilterSpec{datespan=datespan                                     ,cleared=cleared                                     -- ,real=real                                     -- ,empty=empty-                                    -- ,costbasis=_                                     ,acctpats=apats                                     ,descpats=dpats-                                    ,whichdate=whichdate                                     ,depth=depth                                     } =     filterJournalTransactionsByClearedStatus cleared .     filterJournalPostingsByDepth depth .     filterJournalTransactionsByAccount apats .     filterJournalTransactionsByDescription dpats .-    filterJournalTransactionsByDate datespan .-    journalSelectingDate whichdate+    filterJournalTransactionsByDate datespan --- | Keep only postings we are interested in, as described by--- the filter specification. May also massage the data a little.--- This can leave unbalanced transactions.+-- | Keep only postings we are interested in, as described by the filter+-- specification. This can leave unbalanced transactions. filterJournalPostings :: FilterSpec -> Journal -> Journal filterJournalPostings FilterSpec{datespan=datespan                                 ,cleared=cleared                                 ,real=real                                 ,empty=empty---                                ,costbasis=costbasis                                 ,acctpats=apats                                 ,descpats=dpats-                                ,whichdate=whichdate                                 ,depth=depth                                 } =     filterJournalPostingsByRealness real .@@ -140,8 +171,7 @@     filterJournalPostingsByDepth depth .     filterJournalPostingsByAccount apats .     filterJournalTransactionsByDescription dpats .-    filterJournalTransactionsByDate datespan .-    journalSelectingDate whichdate+    filterJournalTransactionsByDate datespan  -- | Keep only transactions whose description matches the description patterns. filterJournalTransactionsByDescription :: [String] -> Journal -> Journal@@ -208,7 +238,7 @@       tmatch t = (null positives || any positivepmatch ps) && (null negatives || not (any negativepmatch ps)) where ps = tpostings t       positivepmatch p = any (`amatch` a) positives where a = paccount p       negativepmatch p = any (`amatch` a) negatives where a = paccount p-      amatch pat a = containsRegex (abspat pat) a+      amatch pat a = regexMatchesCI (abspat pat) a       (negatives,positives) = partition isnegativepat apats  -- | Keep only postings which affect accounts matched by the account patterns.@@ -224,6 +254,13 @@ journalSelectingDate EffectiveDate j =     j{jtxns=map (journalTransactionWithDate EffectiveDate) $ jtxns j} +-- | Apply additional account aliases (eg from the command-line) to all postings in a journal.+journalApplyAliases :: [(AccountName,AccountName)] -> Journal -> Journal+journalApplyAliases aliases j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts}+    where+      fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}+      fixposting p@Posting{paccount=a} = p{paccount=accountNameApplyAliases aliases a}+ -- | Do post-parse processing on a journal, to make it ready for use. journalFinalise :: ClockTime -> LocalTime -> FilePath -> String -> JournalContext -> Journal -> Either String Journal journalFinalise tclock tlocal path txt ctx j@Journal{files=fs} =@@ -291,7 +328,7 @@       fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}       fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}       fixmixedamount (Mixed as) = Mixed $ map fixamount as-      fixamount = canonicaliseAmount (Just $ journalCanonicalCommodities j) . costOfAmount+      fixamount = canonicaliseAmountCommodity (Just $ journalCanonicalCommodities j) . costOfAmount  -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol. journalCanonicalCommodities :: Journal -> Map.Map String Commodity@@ -334,7 +371,7 @@     where       (negatives,positives) = partition isnegativepat pats       match "" = True-      match pat = containsRegex (abspat pat) str+      match pat = regexMatchesCI (abspat pat) str  negateprefix = "not:" @@ -389,6 +426,10 @@       sortedps = sortBy (comparing paccount) ps       groupedps = groupBy (\p1 p2 -> paccount p1 == paccount p2) sortedps       m' = Map.fromList [(paccount $ head g, g) | g <- groupedps]++-- debug helpers+traceAmountPrecision a = trace (show $ map (precision . commodity) $ amounts a) a+tracePostingsCommodities ps = trace (show $ map ((map (precision . commodity) . amounts) . pamount) ps) ps  tests_Hledger_Data_Journal = TestList [  ]

@@ -10,12 +10,17 @@ module Hledger.Data.Ledger where import Data.Map (Map, findWithDefault, fromList)-import Hledger.Data.Utils+import Data.Tree+import Test.HUnit+import Text.Printf++import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Account (nullacct) import Hledger.Data.AccountName import Hledger.Data.Journal import Hledger.Data.Posting+import Hledger.Data.Matching   instance Show Ledger where@@ -41,6 +46,15 @@     where j' = filterJournalPostings fs{depth=Nothing} j           (t, m) = journalAccountInfo j' +-- | Filter a journal's transactions as specified, and then process them+-- to derive a ledger containing all balances, the chart of accounts,+-- canonicalised commodities etc.+-- Like journalToLedger but uses the new matchers.+journalToLedger2 :: Matcher -> Journal -> Ledger+journalToLedger2 m j = nullledger{journal=j',accountnametree=t,accountmap=amap}+    where j' = filterJournalPostings2 m j+          (t, amap) = journalAccountInfo j'+ -- | List a ledger's account names. ledgerAccountNames :: Ledger -> [AccountName] ledgerAccountNames = drop 1 . flatten . accountnametree@@ -56,6 +70,10 @@ -- | List a ledger's top-level accounts, in tree order ledgerTopAccounts :: Ledger -> [Account] ledgerTopAccounts = map root . branches . ledgerAccountTree 9999++-- | List a ledger's bottom-level (subaccount-less) accounts, in tree order+ledgerLeafAccounts :: Ledger -> [Account]+ledgerLeafAccounts = leaves . ledgerAccountTree 9999  -- | Accounts in ledger whose name matches the pattern, in tree order. ledgerAccountsMatching :: [String] -> Ledger -> [Account]

@@ -0,0 +1,317 @@+{-|++More generic matching, done in one step, unlike FilterSpec and filterJournal*. +Currently used only by hledger-web.++-}++module Hledger.Data.Matching+where+import Data.Either+import Data.List+-- import Data.Map (findWithDefault, (!))+import Data.Maybe+-- import Data.Ord+import Data.Time.Calendar+-- import Data.Time.LocalTime+-- import Data.Tree+import Safe (readDef, headDef)+-- import System.Time (ClockTime(TOD))+import Test.HUnit+import Text.ParserCombinators.Parsec+-- import Text.Printf+-- import qualified Data.Map as Map++import Hledger.Utils+import Hledger.Data.Types+import Hledger.Data.AccountName+import Hledger.Data.Amount+-- import Hledger.Data.Commodity (canonicaliseCommodities)+import Hledger.Data.Dates+import Hledger.Data.Posting+import Hledger.Data.Transaction+-- import Hledger.Data.TimeLog++-- | A matcher is a single, or boolean composition of, search criteria,+-- which can be used to match postings, transactions, accounts and more.+-- Currently used by hledger-web, will likely replace FilterSpec at some point.+data Matcher = MatchAny              -- ^ always match+             | MatchNone             -- ^ never match+             | MatchNot Matcher      -- ^ negate this match+             | MatchOr [Matcher]     -- ^ match if any of these match+             | MatchAnd [Matcher]    -- ^ match if all of these match+             | MatchDesc String      -- ^ match if description matches this regexp+             | MatchAcct String      -- ^ match postings whose account matches this regexp+             | MatchDate DateSpan    -- ^ match if actual date in this date span+             | MatchEDate DateSpan   -- ^ match if effective date in this date span+             | MatchStatus Bool      -- ^ match if cleared status has this value+             | MatchReal Bool        -- ^ match if "realness" (involves a real non-virtual account ?) has this value+             | MatchEmpty Bool       -- ^ match if "emptiness" (from the --empty command-line flag) has this value.+                                     --   Currently this means a posting with zero amount.+             | MatchDepth Int        -- ^ match if account depth is less than or equal to this value+    deriving (Show, Eq)++-- | A query option changes a query's/report's behaviour and output in some way.++-- XXX could use regular CliOpts ?+data QueryOpt = QueryOptInAcctOnly AccountName  -- ^ show an account register focussed on this account+              | QueryOptInAcct AccountName      -- ^ as above but include sub-accounts in the account register+           -- | QueryOptCostBasis      -- ^ show amounts converted to cost where possible+           -- | QueryOptEffectiveDate  -- ^ show effective dates instead of actual dates+    deriving (Show, Eq)++-- | The account we are currently focussed on, if any, and whether subaccounts are included.+-- Just looks at the first query option.+inAccount :: [QueryOpt] -> Maybe (AccountName,Bool)+inAccount [] = Nothing+inAccount (QueryOptInAcctOnly a:_) = Just (a,False)+inAccount (QueryOptInAcct a:_) = Just (a,True)++-- | A matcher for the account(s) we are currently focussed on, if any.+-- Just looks at the first query option.+inAccountMatcher :: [QueryOpt] -> Maybe Matcher+inAccountMatcher [] = Nothing+inAccountMatcher (QueryOptInAcctOnly a:_) = Just $ MatchAcct $ accountNameToAccountOnlyRegex a+inAccountMatcher (QueryOptInAcct a:_) = Just $ MatchAcct $ accountNameToAccountRegex a++-- -- | A matcher restricting the account(s) to be shown in the sidebar, if any.+-- -- Just looks at the first query option.+-- showAccountMatcher :: [QueryOpt] -> Maybe Matcher+-- showAccountMatcher (QueryOptInAcctSubsOnly a:_) = Just $ MatchAcct True $ accountNameToAccountRegex a+-- showAccountMatcher _ = Nothing++-- | Convert a query expression containing zero or more space-separated+-- terms to a matcher and zero or more query options. A query term is either:+--+-- 1. a search criteria, used to match transactions. This is usually a prefixed pattern such as:+--    acct:REGEXP+--    date:PERIODEXP+--    not:desc:REGEXP+--+-- 2. a query option, which changes behaviour in some way. There is currently one of these:+--    inacct:FULLACCTNAME - should appear only once+--+-- Multiple search criteria are AND'ed together.+-- When a pattern contains spaces, it or the whole term should be enclosed in single or double quotes.+-- A reference date is required to interpret relative dates in period expressions.+--+parseQuery :: Day -> String -> (Matcher,[QueryOpt])+parseQuery d s = (m,qopts)+  where+    terms = words'' prefixes s+    (matchers, qopts) = partitionEithers $ map (parseMatcher d) terms+    m = case matchers of []      -> MatchAny+                         (m':[]) -> m'+                         ms      -> MatchAnd ms++-- | Quote-and-prefix-aware version of words - don't split on spaces which+-- are inside quotes, including quotes which may have one of the specified+-- prefixes in front, and maybe an additional not: prefix in front of that.+words'' :: [String] -> String -> [String]+words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX+    where+      maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, quotedPattern, pattern] `sepBy` many1 spacenonewline+      prefixedQuotedPattern = do+        not' <- optionMaybe $ string "not:"+        prefix <- choice' $ map string prefixes+        p <- quotedPattern+        return $ fromMaybe "" not' ++ prefix ++ stripquotes p+      quotedPattern = do+        p <- between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\""+        return $ stripquotes p+      pattern = many (noneOf " \n\r\"")++-- -- | Parse the query string as a boolean tree of match patterns.+-- parseMatcher :: String -> Matcher+-- parseMatcher s = either (const (MatchAny)) id $ runParser matcher () "" $ lexmatcher s++-- lexmatcher :: String -> [String]+-- lexmatcher s = words' s++-- matcher :: GenParser String () Matcher+-- matcher = undefined++-- keep synced with patterns below, excluding "not"+prefixes = map (++":") [+            "inacct","inacctonly",+            "desc","acct","date","edate","status","real","empty","depth"+           ]+defaultprefix = "acct"++-- | Parse a single query term as either a matcher or a query option.+parseMatcher :: Day -> String -> Either Matcher QueryOpt+parseMatcher _ ('i':'n':'a':'c':'c':'t':'o':'n':'l':'y':':':s) = Right $ QueryOptInAcctOnly s+parseMatcher _ ('i':'n':'a':'c':'c':'t':':':s) = Right $ QueryOptInAcct s+parseMatcher d ('n':'o':'t':':':s) = case parseMatcher d s of+                                       Left m  -> Left $ MatchNot m+                                       Right _ -> Left MatchAny -- not:somequeryoption will be ignored+parseMatcher _ ('d':'e':'s':'c':':':s) = Left $ MatchDesc s+parseMatcher _ ('a':'c':'c':'t':':':s) = Left $ MatchAcct s+parseMatcher d ('d':'a':'t':'e':':':s) =+        case parsePeriodExpr d s of Left _ -> Left MatchNone -- XXX should warn+                                    Right (_,span) -> Left $ MatchDate span+parseMatcher d ('e':'d':'a':'t':'e':':':s) =+        case parsePeriodExpr d s of Left _ -> Left MatchNone -- XXX should warn+                                    Right (_,span) -> Left $ MatchEDate span+parseMatcher _ ('s':'t':'a':'t':'u':'s':':':s) = Left $ MatchStatus $ parseStatus s+parseMatcher _ ('r':'e':'a':'l':':':s) = Left $ MatchReal $ parseBool s+parseMatcher _ ('e':'m':'p':'t':'y':':':s) = Left $ MatchEmpty $ parseBool s+parseMatcher _ ('d':'e':'p':'t':'h':':':s) = Left $ MatchDepth $ readDef 0 s+parseMatcher _ "" = Left $ MatchAny+parseMatcher d s = parseMatcher d $ defaultprefix++":"++s++-- | Parse the boolean value part of a "status:" matcher, allowing "*" as+-- another way to spell True, similar to the journal file format.+parseStatus :: String -> Bool+parseStatus s = s `elem` (truestrings ++ ["*"])++-- | Parse the boolean value part of a "status:" matcher. A true value can+-- be spelled as "1", "t" or "true".+parseBool :: String -> Bool+parseBool s = s `elem` truestrings++truestrings :: [String]+truestrings = ["1","t","true"]++-- | Convert a match expression to its inverse.+negateMatcher :: Matcher -> Matcher+negateMatcher =  MatchNot++-- | Does the match expression match this posting ?+matchesPosting :: Matcher -> Posting -> Bool+matchesPosting (MatchNot m) p = not $ matchesPosting m p+matchesPosting (MatchAny) _ = True+matchesPosting (MatchNone) _ = False+matchesPosting (MatchOr ms) p = any (`matchesPosting` p) ms+matchesPosting (MatchAnd ms) p = all (`matchesPosting` p) ms+matchesPosting (MatchDesc r) p = regexMatchesCI r $ maybe "" tdescription $ ptransaction p+matchesPosting (MatchAcct r) p = regexMatchesCI r $ paccount p+matchesPosting (MatchDate span) p =+    case d of Just d'  -> spanContainsDate span d'+              Nothing -> False+    where d = maybe Nothing (Just . tdate) $ ptransaction p+matchesPosting (MatchEDate span) p =+    case postingEffectiveDate p of Just d  -> spanContainsDate span d+                                   Nothing -> False+matchesPosting (MatchStatus v) p = v == postingCleared p+matchesPosting (MatchReal v) p = v == isReal p+matchesPosting (MatchEmpty v) Posting{pamount=a} = v == isZeroMixedAmount a+matchesPosting _ _ = False++-- | Does the match expression match this transaction ?+matchesTransaction :: Matcher -> Transaction -> Bool+matchesTransaction (MatchNot m) t = not $ matchesTransaction m t+matchesTransaction (MatchAny) _ = True+matchesTransaction (MatchNone) _ = False+matchesTransaction (MatchOr ms) t = any (`matchesTransaction` t) ms+matchesTransaction (MatchAnd ms) t = all (`matchesTransaction` t) ms+matchesTransaction (MatchDesc r) t = regexMatchesCI r $ tdescription t+matchesTransaction m@(MatchAcct _) t = any (m `matchesPosting`) $ tpostings t+matchesTransaction (MatchDate span) t = spanContainsDate span $ tdate t+matchesTransaction (MatchEDate span) t = spanContainsDate span $ transactionEffectiveDate t+matchesTransaction (MatchStatus v) t = v == tstatus t+matchesTransaction (MatchReal v) t = v == hasRealPostings t+matchesTransaction _ _ = False++postingEffectiveDate :: Posting -> Maybe Day+postingEffectiveDate p = maybe Nothing (Just . transactionEffectiveDate) $ ptransaction p++transactionEffectiveDate :: Transaction -> Day+transactionEffectiveDate t = case teffectivedate t of Just d  -> d+                                                      Nothing -> tdate t++-- | Does the match expression match this account ?+-- A matching in: clause is also considered a match.+matchesAccount :: Matcher -> AccountName -> Bool+matchesAccount (MatchNot m) a = not $ matchesAccount m a+matchesAccount (MatchAny) _ = True+matchesAccount (MatchNone) _ = False+matchesAccount (MatchOr ms) a = any (`matchesAccount` a) ms+matchesAccount (MatchAnd ms) a = all (`matchesAccount` a) ms+matchesAccount (MatchAcct r) a = regexMatchesCI r a+matchesAccount _ _ = False++-- | What start date does this matcher specify, if any ?+-- If the matcher is an OR expression, returns the earliest of the alternatives.+-- When the flag is true, look for a starting effective date instead.+matcherStartDate :: Bool -> Matcher -> Maybe Day+matcherStartDate effective (MatchOr ms) = earliestMaybeDate $ map (matcherStartDate effective) ms+matcherStartDate effective (MatchAnd ms) = latestMaybeDate $ map (matcherStartDate effective) ms+matcherStartDate False (MatchDate (DateSpan (Just d) _)) = Just d+matcherStartDate True (MatchEDate (DateSpan (Just d) _)) = Just d+matcherStartDate _ _ = Nothing++-- | Does this matcher specify a start date and nothing else (that would+-- filter postings prior to the date) ?+-- When the flag is true, look for a starting effective date instead.+matcherIsStartDateOnly :: Bool -> Matcher -> Bool+matcherIsStartDateOnly _ MatchAny = False+matcherIsStartDateOnly _ MatchNone = False+matcherIsStartDateOnly effective (MatchOr ms) = and $ map (matcherIsStartDateOnly effective) ms+matcherIsStartDateOnly effective (MatchAnd ms) = and $ map (matcherIsStartDateOnly effective) ms+matcherIsStartDateOnly False (MatchDate (DateSpan (Just _) _)) = True+matcherIsStartDateOnly True (MatchEDate (DateSpan (Just _) _)) = True+matcherIsStartDateOnly _ _ = False++-- | Does this matcher match everything ?+matcherIsNull MatchAny = True+matcherIsNull (MatchAnd []) = True+matcherIsNull (MatchNot (MatchOr [])) = True+matcherIsNull _ = False++-- | What is the earliest of these dates, where Nothing is earliest ?+earliestMaybeDate :: [Maybe Day] -> Maybe Day+earliestMaybeDate = headDef Nothing . sortBy compareMaybeDates++-- | What is the latest of these dates, where Nothing is earliest ?+latestMaybeDate :: [Maybe Day] -> Maybe Day+latestMaybeDate = headDef Nothing . sortBy (flip compareMaybeDates)++-- | Compare two maybe dates, Nothing is earliest.+compareMaybeDates :: Maybe Day -> Maybe Day -> Ordering+compareMaybeDates Nothing Nothing = EQ+compareMaybeDates Nothing (Just _) = LT+compareMaybeDates (Just _) Nothing = GT+compareMaybeDates (Just a) (Just b) = compare a b++tests_Hledger_Data_Matching :: Test+tests_Hledger_Data_Matching = TestList+ [++  "parseQuery" ~: do+    let d = parsedate "2011/1/1"+    parseQuery d "a" `is` (MatchAcct "a", [])+    parseQuery d "acct:a" `is` (MatchAcct "a", [])+    parseQuery d "acct:a desc:b" `is` (MatchAnd [MatchAcct "a", MatchDesc "b"], [])+    parseQuery d "\"acct:expenses:autres d\233penses\"" `is` (MatchAcct "expenses:autres d\233penses", [])+    parseQuery d "not:desc:'a b'" `is` (MatchNot $ MatchDesc "a b", [])++    parseQuery d "inacct:a desc:b" `is` (MatchDesc "b", [QueryOptInAcct "a"])+    parseQuery d "inacct:a inacct:b" `is` (MatchAny, [QueryOptInAcct "a", QueryOptInAcct "b"])++    parseQuery d "status:1" `is` (MatchStatus True, [])+    parseQuery d "status:0" `is` (MatchStatus False, [])+    parseQuery d "status:" `is` (MatchStatus False, [])+    parseQuery d "real:1" `is` (MatchReal True, [])++  ,"matchesAccount" ~: do+    assertBool "positive acct match" $ matchesAccount (MatchAcct "b:c") "a:bb:c:d"+    -- assertBool "acct should match at beginning" $ not $ matchesAccount (MatchAcct True "a:b") "c:a:b"++  ,"matchesPosting" ~: do+    -- matching posting status..+    assertBool "positive match on true posting status"  $+                   (MatchStatus True)  `matchesPosting` nullposting{pstatus=True}+    assertBool "negative match on true posting status"  $+               not $ (MatchNot $ MatchStatus True)  `matchesPosting` nullposting{pstatus=True}+    assertBool "positive match on false posting status" $+                   (MatchStatus False) `matchesPosting` nullposting{pstatus=False}+    assertBool "negative match on false posting status" $+               not $ (MatchNot $ MatchStatus False) `matchesPosting` nullposting{pstatus=False}+    assertBool "positive match on true posting status acquired from transaction" $+                   (MatchStatus True) `matchesPosting` nullposting{pstatus=False,ptransaction=Just nulltransaction{tstatus=True}}+    assertBool "real:1 on real posting" $ (MatchReal True) `matchesPosting` nullposting{ptype=RegularPosting}+    assertBool "real:1 on virtual posting fails" $ not $ (MatchReal True) `matchesPosting` nullposting{ptype=VirtualPosting}+    assertBool "real:1 on balanced virtual posting fails" $ not $ (MatchReal True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting}++ ]

@@ -10,7 +10,14 @@  module Hledger.Data.Posting where-import Hledger.Data.Utils+import Data.List+import Data.Ord+import Data.Time.Calendar+import Safe+import Test.HUnit+import Text.Printf++import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Amount import Hledger.Data.AccountName@@ -19,6 +26,7 @@  instance Show Posting where show = showPosting +nullposting :: Posting nullposting = Posting False "" nullmixedamt "" RegularPosting [] Nothing  showPosting :: Posting -> String@@ -32,7 +40,7 @@                           BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)                           VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)                           _ -> (id,acctnamewidth)-      showamount = padleft 12 . showMixedAmountOrZero+      showamount = padleft 12 . showMixedAmount       comment = if null com then "" else "  ; " ++ com -- XXX refactor showPostingForRegister :: Posting -> String@@ -46,7 +54,7 @@                           BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)                           VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)                           _ -> (id,acctnamewidth)-      showamount = padleft 12 . showMixedAmountOrZeroWithoutPrice+      showamount = padleft 12 . showMixedAmountWithoutPrice  isReal :: Posting -> Bool isReal p = ptype p == RegularPosting@@ -60,16 +68,11 @@ hasAmount :: Posting -> Bool hasAmount = (/= missingamt) . pamount -postingTypeFromAccountName a-    | head a == '[' && last a == ']' = BalancedVirtualPosting-    | head a == '(' && last a == ')' = VirtualPosting-    | otherwise = RegularPosting- accountNamesFromPostings :: [Posting] -> [AccountName] accountNamesFromPostings = nub . map paccount  sumPostings :: [Posting] -> MixedAmount-sumPostings = sumMixedAmountsPreservingHighestPrecision . map pamount+sumPostings = sum . map pamount  postingDate :: Posting -> Day postingDate p = maybe nulldate tdate $ ptransaction p@@ -97,6 +100,69 @@ postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps')     where ps' = sortBy (comparing postingDate) ps +-- AccountName stuff that depends on PostingType++accountNamePostingType :: AccountName -> PostingType+accountNamePostingType a+    | null a = RegularPosting+    | head a == '[' && last a == ']' = BalancedVirtualPosting+    | head a == '(' && last a == ')' = VirtualPosting+    | otherwise = RegularPosting++accountNameWithoutPostingType :: AccountName -> AccountName+accountNameWithoutPostingType a = case accountNamePostingType a of+                                    BalancedVirtualPosting -> init $ tail a+                                    VirtualPosting -> init $ tail a+                                    RegularPosting -> a++accountNameWithPostingType :: PostingType -> AccountName -> AccountName+accountNameWithPostingType BalancedVirtualPosting a = "["++accountNameWithoutPostingType a++"]"+accountNameWithPostingType VirtualPosting a = "("++accountNameWithoutPostingType a++")"+accountNameWithPostingType RegularPosting a = accountNameWithoutPostingType a++-- | Prefix one account name to another, preserving posting type+-- indicators like concatAccountNames.+joinAccountNames :: AccountName -> AccountName -> AccountName+joinAccountNames a b = concatAccountNames $ filter (not . null) [a,b]++-- | Join account names into one. If any of them has () or [] posting type+-- indicators, these (the first type encountered) will also be applied to+-- the resulting account name.+concatAccountNames :: [AccountName] -> AccountName+concatAccountNames as = accountNameWithPostingType t $ intercalate ":" $ map accountNameWithoutPostingType as+    where t = headDef RegularPosting $ filter (/= RegularPosting) $ map accountNamePostingType as++-- | Rewrite an account name using the first applicable alias from the given list, if any.+accountNameApplyAliases :: [(AccountName,AccountName)] -> AccountName -> AccountName+accountNameApplyAliases aliases a = withorigtype+    where+      (a',t) = (accountNameWithoutPostingType a, accountNamePostingType a)+      firstmatchingalias = headDef Nothing $ map Just $ filter (\(orig,_) -> orig == a' || orig `isAccountNamePrefixOf` a') aliases+      rewritten = maybe a' (\(orig,alias) -> alias++drop (length orig) a') firstmatchingalias+      withorigtype = accountNameWithPostingType t rewritten+ tests_Hledger_Data_Posting = TestList [++  "accountNamePostingType" ~: do+    accountNamePostingType "a" `is` RegularPosting+    accountNamePostingType "(a)" `is` VirtualPosting+    accountNamePostingType "[a]" `is` BalancedVirtualPosting++ ,"accountNameWithoutPostingType" ~: do+    accountNameWithoutPostingType "(a)" `is` "a"++ ,"accountNameWithPostingType" ~: do+    accountNameWithPostingType VirtualPosting "[a]" `is` "(a)"++ ,"joinAccountNames" ~: do+    "a" `joinAccountNames` "b:c" `is` "a:b:c"+    "a" `joinAccountNames` "(b:c)" `is` "(a:b:c)"+    "[a]" `joinAccountNames` "(b:c)" `is` "[a:b:c]"+    "" `joinAccountNames` "a" `is` "a"++ ,"concatAccountNames" ~: do+    concatAccountNames [] `is` ""+    concatAccountNames ["a","(b)","[c:d]"] `is` "(a:b:c:d)"+  ] 

@@ -8,9 +8,16 @@  module Hledger.Data.TimeLog where+import Data.Maybe+import Data.Time.Calendar+import Data.Time.Clock import Data.Time.Format+import Data.Time.LocalTime import System.Locale (defaultTimeLocale)-import Hledger.Data.Utils+import Test.HUnit+import Text.Printf++import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Dates import Hledger.Data.Commodity

@@ -8,9 +8,13 @@  module Hledger.Data.Transaction where+import Data.List+import Data.Maybe+import Test.HUnit+import Text.Printf import qualified Data.Map as Map -import Hledger.Data.Utils+import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Dates import Hledger.Data.Posting@@ -91,7 +95,7 @@                 where w = maximum $ map (length . paccount) ps                       showstatus p = if pstatus p then "* " else ""             showamt =-                padleft 12 . showMixedAmountOrZero+                padleft 12 . showMixedAmount             showcomment s = if null s then "" else "  ; "++s  -- | Show an account name, clipped to the given width if any, and@@ -106,6 +110,9 @@       parenthesise s = "("++s++")"       bracket s = "["++s++"]" +hasRealPostings :: Transaction -> Bool+hasRealPostings = not . null . realPostings+ realPostings :: Transaction -> [Posting] realPostings = filter isReal . tpostings @@ -115,6 +122,9 @@ balancedVirtualPostings :: Transaction -> [Posting] balancedVirtualPostings = filter isBalancedVirtual . tpostings +transactionsPostings :: [Transaction] -> [Posting]+transactionsPostings = concat . map tpostings+ -- | Get the sums of a transaction's real, virtual, and balanced virtual postings. transactionPostingBalances :: Transaction -> (MixedAmount,MixedAmount,MixedAmount) transactionPostingBalances t = (sumPostings $ realPostings t@@ -130,8 +140,8 @@     isZeroMixedAmount rsum' && isZeroMixedAmount bvsum'     where       (rsum, _, bvsum) = transactionPostingBalances t-      rsum'  = canonicaliseMixedAmount canonicalcommoditymap $ costOfMixedAmount rsum-      bvsum' = canonicaliseMixedAmount canonicalcommoditymap $ costOfMixedAmount bvsum+      rsum'  = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount rsum+      bvsum' = canonicaliseMixedAmountCommodity canonicalcommoditymap $ costOfMixedAmount bvsum  -- | Ensure this transaction is balanced, possibly inferring a missing -- amount or a conversion price first, or return an error message.@@ -179,9 +189,10 @@                 where                   conversionprice c | c == unpricedcommodity                                         -- assign a balancing price. Use @@ for more exact output when possible.+                                        -- invariant: prices should always be positive. Enforced with "abs"                                         = if length ramountsinunpricedcommodity == 1-                                           then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ negate $ targetcommodityamount]-                                           else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ negate $ targetcommodityamount `divideAmount` (quantity unpricedamount)]+                                           then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount]+                                           else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (quantity unpricedamount)]                                     | otherwise = Nothing                       where                         unpricedcommodity     = head $ filter (`elem` (map commodity rsumamounts)) rcommoditiesinorder@@ -204,8 +215,8 @@                 where                   conversionprice c | c == unpricedcommodity                                         = if length bvamountsinunpricedcommodity == 1-                                           then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ negate $ targetcommodityamount]-                                           else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ negate $ targetcommodityamount `divideAmount` (quantity unpricedamount)]+                                           then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount]+                                           else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ abs $ targetcommodityamount `divideAmount` (quantity unpricedamount)]                                     | otherwise = Nothing                       where                         unpricedcommodity     = head $ filter (`elem` (map commodity bvsumamounts)) bvcommoditiesinorder

@@ -4,15 +4,15 @@ Most data types are defined here to avoid import cycles. Here is an overview of the hledger data model: -> Journal                  -- a journal is derived from one or more data files. It contains..->  [Transaction]           -- journal transactions, which have date, status, code, description and..->   [Posting]              -- multiple account postings (entries), which have account name and amount.+> Journal                  -- a journal is read from one or more data files. It contains..+>  [Transaction]           -- journal transactions (aka entries), which have date, status, code, description and..+>   [Posting]              -- multiple account postings, which have account name and amount >  [HistoricalPrice]       -- historical commodity prices > > Ledger                   -- a ledger is derived from a journal, by applying a filter specification and doing some further processing. It contains..->  Journal                 -- the filtered journal, containing only the transactions and postings we are interested in->  Tree AccountName        -- account names referenced in the journal's transactions, as a tree->  Map AccountName Account -- per-account postings and balances from the journal's transactions, as a  map from account name to account info+>  Journal                 -- a filtered copy of the original journal, containing only the transactions and postings we are interested in+>  Tree AccountName        -- all accounts named by the journal's transactions, as a hierarchy+>  Map AccountName Account -- the postings, and resulting balances, in each account  For more detailed documentation on each type, see the corresponding modules. @@ -33,13 +33,14 @@ module Hledger.Data.Types where import Control.Monad.Error (ErrorT)-import Data.Typeable (Typeable)+import Data.Time.Calendar+import Data.Time.LocalTime+import Data.Tree+import Data.Typeable import qualified Data.Map as Map import System.Time (ClockTime) -import Hledger.Data.Utils - type SmartDate = (String,String,String)  data WhichDate = ActualDate | EffectiveDate deriving (Eq,Show)@@ -68,9 +69,10 @@       separatorpositions :: [Int]  -- ^ positions of separators, counting leftward from decimal point     } deriving (Eq,Ord,Show,Read) --- | An amount's price may be written as \@ unit price or \@\@ total price.--- Note although Price has a MixedAmount, it should hold only--- single-commodity amounts, cf costOfAmount.+-- | An amount's price in another commodity may be written as \@ unit+-- price or \@\@ total price.  Note although a MixedAmount is used, it+-- should be in a single commodity, also the amount should be positive;+-- these are not enforced currently. data Price = UnitPrice MixedAmount | TotalPrice MixedAmount              deriving (Eq,Ord) @@ -146,7 +148,10 @@ data JournalContext = Ctx {       ctxYear      :: !(Maybe Year)      -- ^ the default year most recently specified with Y     , ctxCommodity :: !(Maybe Commodity) -- ^ the default commodity most recently specified with D-    , ctxAccount   :: ![AccountName]     -- ^ the current stack of parent accounts specified by !account+    , ctxAccount   :: ![AccountName]     -- ^ the current stack of parent accounts/account name components+                                        --   specified with "account" directive(s). Concatenated, these+                                        --   are the account prefix prepended to parsed account names.+    , ctxAliases   :: ![(AccountName,AccountName)] -- ^ the current list of account name aliases in effect     } deriving (Read, Show, Eq)  data Journal = Journal {@@ -187,16 +192,14 @@       abalance :: MixedAmount    -- ^ sum of postings in this account and subaccounts     } --- | A generic, pure specification of how to filter transactions and postings.+-- | A generic, pure specification of how to filter (or search) transactions and postings. data FilterSpec = FilterSpec {      datespan  :: DateSpan   -- ^ only include if in this date span     ,cleared   :: Maybe Bool -- ^ only include if cleared\/uncleared\/don't care     ,real      :: Bool       -- ^ only include if real\/don't care     ,empty     :: Bool       -- ^ include if empty (ie amount is zero)-    ,costbasis :: Bool       -- ^ convert all amounts to cost basis     ,acctpats  :: [String]   -- ^ only include if matching these account patterns     ,descpats  :: [String]   -- ^ only include if matching these description patterns-    ,whichdate :: WhichDate  -- ^ which dates to use (actual or effective)     ,depth     :: Maybe Int     } deriving (Show) 

@@ -1,83 +0,0 @@-{--From pandoc, slightly extended.-------------------------------------------------------------------------Copyright (C) 2010 John MacFarlane <jgm@berkeley.edu>--This program is free software; you can redistribute it and/or modify-it under the terms of the GNU General Public License as published by-the Free Software Foundation; either version 2 of the License, or-(at your option) any later version.--This program is distributed in the hope that it will be useful,-but WITHOUT ANY WARRANTY; without even the implied warranty of-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-GNU General Public License for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--}--{- |-   Module      : Text.Pandoc.UTF8-   Copyright   : Copyright (C) 2010 John MacFarlane-   License     : GNU GPL, version 2 or above --   Maintainer  : John MacFarlane <jgm@berkeley.edu>-   Stability   : alpha-   Portability : portable--UTF-8 aware string IO functions that will work with GHC 6.10 or 6.12.--}-module Hledger.Data.UTF8 ( readFile-                         , writeFile-                         , appendFile-                         , getContents-                         , hGetContents-                         , putStr-                         , putStrLn-                         , hPutStr-                         , hPutStrLn-                         )--where-import qualified Data.ByteString.Lazy as B-import Data.ByteString.Lazy.UTF8 (toString, fromString)-import Prelude hiding (readFile, writeFile, appendFile, getContents, putStr, putStrLn)-import System.IO (Handle)-import Control.Monad (liftM)--bom :: B.ByteString-bom = B.pack [0xEF, 0xBB, 0xBF]--stripBOM :: B.ByteString -> B.ByteString-stripBOM s | bom `B.isPrefixOf` s = B.drop 3 s-stripBOM s = s--readFile :: FilePath -> IO String-readFile = liftM (toString . stripBOM) . B.readFile--writeFile :: FilePath -> String -> IO ()-writeFile f = B.writeFile f . fromString--appendFile :: FilePath -> String -> IO ()-appendFile f = B.appendFile f . fromString--getContents :: IO String-getContents = liftM (toString . stripBOM) B.getContents--hGetContents :: Handle -> IO String-hGetContents h = liftM (toString . stripBOM) (B.hGetContents h)--putStr :: String -> IO ()-putStr = B.putStr . fromString--putStrLn :: String -> IO ()-putStrLn = B.putStrLn . fromString--hPutStr :: Handle -> String -> IO ()-hPutStr h = B.hPutStr h . fromString--hPutStrLn :: Handle -> String -> IO ()-hPutStrLn h s = hPutStr h (s ++ "\n")

@@ -1,376 +0,0 @@-{-# LANGUAGE CPP #-}-{-|--Standard imports and utilities which are useful everywhere, or needed low-in the module hierarchy. This is the bottom of hledger's module graph.---}--module Hledger.Data.Utils (-module Data.Char,-module Control.Monad,-module Data.List,---module Data.Map,-module Data.Maybe,-module Data.Ord,-module Data.Tree,-module Data.Time.Clock,-module Data.Time.Calendar,-module Data.Time.LocalTime,-module Debug.Trace,-module Hledger.Data.Utils,--- module Hledger.Data.UTF8,-module Text.Printf,-module Text.RegexPR,-module Test.HUnit,-)-where-import Data.Char-import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded)-import Control.Monad-import Data.List---import qualified Data.Map as Map-import Data.Maybe-import Data.Ord-import Data.Tree-import Data.Time.Clock-import Data.Time.Calendar-import Data.Time.LocalTime-import Debug.Trace--- needs to be done in each module I think--- import Prelude hiding (readFile,writeFile,getContents,putStr,putStrLn)--- import Hledger.Data.UTF8-import Test.HUnit-import Text.Printf-import Text.RegexPR-import Text.ParserCombinators.Parsec-import System.Info (os)----- strings--lowercase = map toLower-uppercase = map toUpper--strip = lstrip . rstrip-lstrip = dropws-rstrip = reverse . dropws . reverse-dropws = dropWhile (`elem` " \t")--elideLeft width s =-    if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s--elideRight width s =-    if length s > width then take (width - 2) s ++ ".." else s--underline :: String -> String-underline s = s' ++ replicate (length s) '-' ++ "\n"-    where s'-            | last s == '\n' = s-            | otherwise = s ++ "\n"--unbracket :: String -> String-unbracket s-    | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s-    | otherwise = s---- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded.-concatTopPadded :: [String] -> String-concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded-    where-      lss = map lines strs-      h = maximum $ map length lss-      ypad ls = replicate (difforzero h (length ls)) "" ++ ls-      xpad ls = map (padleft w) ls where w | null ls = 0-                                           | otherwise = maximum $ map length ls-      padded = map (xpad . ypad) lss---- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.-concatBottomPadded :: [String] -> String-concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded-    where-      lss = map lines strs-      h = maximum $ map length lss-      ypad ls = ls ++ replicate (difforzero h (length ls)) ""-      xpad ls = map (padleft w) ls where w | null ls = 0-                                           | otherwise = maximum $ map length ls-      padded = map (xpad . ypad) lss---- | Compose strings vertically and right-aligned.-vConcatRightAligned :: [String] -> String-vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss-    where-      showfixedwidth = printf (printf "%%%ds" width)-      width = maximum $ map length ss---- | Convert a multi-line string to a rectangular string top-padded to the specified height.-padtop :: Int -> String -> String-padtop h s = intercalate "\n" xpadded-    where-      ls = lines s-      sh = length ls-      sw | null ls = 0-         | otherwise = maximum $ map length ls-      ypadded = replicate (difforzero h sh) "" ++ ls-      xpadded = map (padleft sw) ypadded---- | Convert a multi-line string to a rectangular string bottom-padded to the specified height.-padbottom :: Int -> String -> String-padbottom h s = intercalate "\n" xpadded-    where-      ls = lines s-      sh = length ls-      sw | null ls = 0-         | otherwise = maximum $ map length ls-      ypadded = ls ++ replicate (difforzero h sh) ""-      xpadded = map (padleft sw) ypadded---- | Convert a multi-line string to a rectangular string left-padded to the specified width.-padleft :: Int -> String -> String-padleft w "" = concat $ replicate w " "-padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s---- | Convert a multi-line string to a rectangular string right-padded to the specified width.-padright :: Int -> String -> String-padright w "" = concat $ replicate w " "-padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s---- | Clip a multi-line string to the specified width and height from the top left.-cliptopleft :: Int -> Int -> String -> String-cliptopleft w h = intercalate "\n" . take h . map (take w) . lines---- | Clip and pad a multi-line string to fill the specified width and height.-fitto :: Int -> Int -> String -> String-fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline-    where-      rows = map (fit w) $ lines s-      fit w = take w . (++ repeat ' ')-      blankline = replicate w ' '---- encoded platform strings---- | A platform string is a string value from or for the operating system,--- such as a file path or command-line argument (or environment variable's--- name or value ?). On some platforms (such as unix) these are not real--- unicode strings but have some encoding such as UTF-8. This alias does--- no type enforcement but aids code clarity.-type PlatformString = String---- | Convert a possibly encoded platform string to a real unicode string.--- We decode the UTF-8 encoding recommended for unix systems--- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)--- and leave anything else unchanged.-fromPlatformString :: PlatformString -> String-fromPlatformString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s---- | Convert a unicode string to a possibly encoded platform string.--- On unix we encode with the recommended UTF-8--- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)--- and elsewhere we leave it unchanged.-toPlatformString :: String -> PlatformString-toPlatformString = case os of-                     "unix" -> UTF8.encodeString-                     "linux" -> UTF8.encodeString-                     "darwin" -> UTF8.encodeString-                     _ -> id---- | A version of error that's better at displaying unicode.-error' :: String -> a-error' = error . toPlatformString---- | A version of userError that's better at displaying unicode.-userError' :: String -> IOError-userError' = userError . toPlatformString---- math--difforzero :: (Num a, Ord a) => a -> a -> a-difforzero a b = maximum [(a - b), 0]---- regexps--containsRegex :: String -> String -> Bool-containsRegex r s = case matchRegexPR ("(?i)"++r) s of-                      Just _ -> True-                      _ -> False----- lists--splitAtElement :: Eq a => a -> [a] -> [[a]]-splitAtElement e l = -    case dropWhile (e==) l of-      [] -> []-      l' -> first : splitAtElement e rest-        where-          (first,rest) = break (e==) l'---- trees--root = rootLabel-subs = subForest-branches = subForest---- | List just the leaf nodes of a tree-leaves :: Tree a -> [a]-leaves (Node v []) = [v]-leaves (Node _ branches) = concatMap leaves branches---- | get the sub-tree rooted at the first (left-most, depth-first) occurrence--- of the specified node value-subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a)-subtreeat v t-    | root t == v = Just t-    | otherwise = subtreeinforest v $ subs t---- | get the sub-tree for the specified node value in the first tree in--- forest in which it occurs.-subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a)-subtreeinforest _ [] = Nothing-subtreeinforest v (t:ts) = case (subtreeat v t) of-                             Just t' -> Just t'-                             Nothing -> subtreeinforest v ts-          --- | remove all nodes past a certain depth-treeprune :: Int -> Tree a -> Tree a-treeprune 0 t = Node (root t) []-treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t)---- | apply f to all tree nodes-treemap :: (a -> b) -> Tree a -> Tree b-treemap f t = Node (f $ root t) (map (treemap f) $ branches t)---- | remove all subtrees whose nodes do not fulfill predicate-treefilter :: (a -> Bool) -> Tree a -> Tree a-treefilter f t = Node -                 (root t) -                 (map (treefilter f) $ filter (treeany f) $ branches t)-    --- | is predicate true in any node of tree ?-treeany :: (a -> Bool) -> Tree a -> Bool-treeany f t = f (root t) || any (treeany f) (branches t)-    --- treedrop -- remove the leaves which do fulfill predicate. --- treedropall -- do this repeatedly.---- | show a compact ascii representation of a tree-showtree :: Show a => Tree a -> String-showtree = unlines . filter (containsRegex "[^ \\|]") . lines . drawTree . treemap show---- | show a compact ascii representation of a forest-showforest :: Show a => Forest a -> String-showforest = concatMap showtree---- debugging---- | trace (print on stdout at runtime) a showable expression--- (for easily tracing in the middle of a complex expression)-strace :: Show a => a -> a-strace a = trace (show a) a---- | labelled trace - like strace, with a label prepended-ltrace :: Show a => String -> a -> a-ltrace l a = trace (l ++ ": " ++ show a) a---- | monadic trace - like strace, but works as a standalone line in a monad-mtrace :: (Monad m, Show a) => a -> m a-mtrace a = strace a `seq` return a---- | trace an expression using a custom show function-tracewith f e = trace (f e) e---- parsing--choice' :: [GenParser tok st a] -> GenParser tok st a-choice' = choice . map Text.ParserCombinators.Parsec.try--parsewith :: Parser a -> String -> Either ParseError a-parsewith p = parse p ""--parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a-parseWithCtx ctx p = runParser p ctx ""--fromparse :: Either ParseError a -> a-fromparse = either parseerror id--parseerror e = error' $ showParseError e--showParseError e = "parse error at " ++ show e--showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)--nonspace :: GenParser Char st Char-nonspace = satisfy (not . isSpace)--spacenonewline :: GenParser Char st Char-spacenonewline = satisfy (`elem` " \v\f\t")--restofline :: GenParser Char st String-restofline = anyChar `manyTill` newline---- time--getCurrentLocalTime :: IO LocalTime-getCurrentLocalTime = do-  t <- getCurrentTime-  tz <- getCurrentTimeZone-  return $ utcToLocalTime tz t---- testing---- | Get a Test's label, or the empty string.-tname :: Test -> String-tname (TestLabel n _) = n-tname _ = ""---- | Flatten a Test containing TestLists into a list of single tests.-tflatten :: Test -> [Test]-tflatten (TestLabel _ t@(TestList _)) = tflatten t-tflatten (TestList ts) = concatMap tflatten ts-tflatten t = [t]---- | Filter TestLists in a Test, recursively, preserving the structure.-tfilter :: (Test -> Bool) -> Test -> Test-tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts)-tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts-tfilter _ t = t---- | Simple way to assert something is some expected value, with no label.-is :: (Eq a, Show a) => a -> a -> Assertion-a `is` e = assertEqual "" e a---- | Assert a parse result is successful, printing the parse error on failure.-assertParse :: (Either ParseError a) -> Assertion-assertParse parse = either (assertFailure.show) (const (return ())) parse---- | Assert a parse result is some expected value, printing the parse error on failure.-assertParseEqual :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion-assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse--printParseError :: (Show a) => a -> IO ()-printParseError e = do putStr "parse error at "; print e----- misc--isLeft :: Either a b -> Bool-isLeft (Left _) = True-isLeft _        = False--isRight :: Either a b -> Bool-isRight = not . isLeft---- -- | Expand ~ in a file path (does not handle ~name).--- tildeExpand :: FilePath -> IO FilePath--- tildeExpand ('~':[])     = getHomeDirectory--- tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs))--- --handle ~name, requires -fvia-C or ghc 6.8:--- --import System.Posix.User--- -- tildeExpand ('~':xs)     =  do let (user, path) = span (/= '/') xs--- --                                pw <- getUserEntryForName user--- --                                return (homeDirectory pw ++ path)--- tildeExpand xs           =  return xs---- | Apply a function the specified number of times. Possibly uses O(n) stack ?-applyN :: Int -> (a -> a) -> a -> a-applyN n f = (!! n) . iterate f

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-|   Read hledger data from various data formats, and related utilities.@@ -10,28 +9,35 @@        readJournalFile,        readJournal,        journalFromPathAndString,+       ledgeraccountname,        myJournalPath,        myTimelogPath,        myJournal,        myTimelog,+       someamount,+       journalenvvar,+       journaldefaultfilename ) where import Control.Monad.Error import Data.Either (partitionEithers)+import Data.List import Safe (headDef) import System.Directory (doesFileExist, getHomeDirectory) import System.Environment (getEnv) import System.FilePath ((</>)) import System.IO (IOMode(..), withFile, stderr)+import Test.HUnit+import Text.Printf  import Hledger.Data.Dates (getCurrentDay) import Hledger.Data.Types (Journal(..), Reader(..)) import Hledger.Data.Journal (nullctx)-import Hledger.Data.Utils-import Prelude hiding (getContents)-import Hledger.Data.UTF8 (getContents, hGetContents) import Hledger.Read.JournalReader as JournalReader import Hledger.Read.TimelogReader as TimelogReader+import Hledger.Utils+import Prelude hiding (getContents)+import Hledger.Utils.UTF8 (getContents, hGetContents)   journalenvvar           = "LEDGER_FILE"

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-|  A reader for hledger's (and c++ ledger's) journal file format.@@ -110,22 +109,34 @@        ledgeraccountname,        ledgerdatetime,        ledgerDefaultYear,-       ledgerExclamationDirective,+       ledgerDirective,        ledgerHistoricalPrice,        reader,        someamount,        tests_Hledger_Read_JournalReader ) where-import Control.Monad.Error (ErrorT(..), throwError, catchError)+import Control.Monad+import Control.Monad.Error+import Data.Char (isNumber)+import Data.List import Data.List.Split (wordsBy)+import Data.Maybe+import Data.Time.Calendar+-- import Data.Time.Clock+-- import Data.Time.Format+import Data.Time.LocalTime import Safe (headDef)+-- import System.Locale (defaultTimeLocale)+import Test.HUnit import Text.ParserCombinators.Parsec hiding (parse)+import Text.Printf  import Hledger.Data-import Prelude hiding (readFile)-import Hledger.Data.UTF8 (readFile) import Hledger.Read.Utils+import Hledger.Utils+import Prelude hiding (readFile)+import Hledger.Utils.UTF8 (readFile)   -- let's get to it@@ -158,22 +169,13 @@       -- As all journal line types can be distinguished by the first       -- character, excepting transactions versus empty (blank or       -- comment-only) lines, can use choice w/o try-      journalItem = choice [ ledgerExclamationDirective-                          , liftM (return . addTransaction) ledgerTransaction-                          , liftM (return . addModifierTransaction) ledgerModifierTransaction-                          , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction-                          , liftM (return . addHistoricalPrice) ledgerHistoricalPrice-                          , ledgerDefaultYear-                          , ledgerDefaultCommodity-                          , ledgerCommodityConversion-                          , ledgerIgnoredPriceCommodity-                          , ledgerTagDirective-                          , ledgerEndTagDirective-                          , emptyLine >> return (return id)-                          ] <?> "journal transaction or directive"--journalAddFile :: (FilePath,String) -> Journal -> Journal-journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}+      journalItem = choice [ ledgerDirective+                           , liftM (return . addTransaction) ledgerTransaction+                           , liftM (return . addModifierTransaction) ledgerModifierTransaction+                           , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction+                           , liftM (return . addHistoricalPrice) ledgerHistoricalPrice+                           , emptyLine >> return (return id)+                           ] <?> "journal transaction or directive"  emptyLine :: GenParser Char JournalContext () emptyLine = do many spacenonewline@@ -197,18 +199,27 @@   return s   <?> "comment" -ledgerExclamationDirective :: GenParser Char JournalContext JournalUpdate-ledgerExclamationDirective = do-  char '!' <?> "directive"-  directive <- many nonspace-  case directive of-    "include" -> ledgerInclude-    "account" -> ledgerAccountBegin-    "end"     -> ledgerAccountEnd-    _         -> mzero+ledgerDirective :: GenParser Char JournalContext JournalUpdate+ledgerDirective = do+  optional $ char '!'+  choice' [+    ledgerInclude+   ,ledgerAlias+   ,ledgerEndAliases+   ,ledgerAccountBegin+   ,ledgerAccountEnd+   ,ledgerTagDirective+   ,ledgerEndTagDirective+   ,ledgerDefaultYear+   ,ledgerDefaultCommodity+   ,ledgerCommodityConversion+   ,ledgerIgnoredPriceCommodity+   ]+  <?> "directive"  ledgerInclude :: GenParser Char JournalContext JournalUpdate ledgerInclude = do+  string "include"   many1 spacenonewline   filename <- restofline   outerState <- getState@@ -223,64 +234,41 @@                 ErrorT $ liftM Right (readFile fp) `catch`                   \err -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show err) -ledgerAccountBegin :: GenParser Char JournalContext JournalUpdate-ledgerAccountBegin = do many1 spacenonewline-                        parent <- ledgeraccountname-                        newline-                        pushParentAccount parent-                        return $ return id--ledgerAccountEnd :: GenParser Char JournalContext JournalUpdate-ledgerAccountEnd = popParentAccount >> return (return id)--ledgerModifierTransaction :: GenParser Char JournalContext ModifierTransaction-ledgerModifierTransaction = do-  char '=' <?> "modifier transaction"-  many spacenonewline-  valueexpr <- restofline-  postings <- ledgerpostings-  return $ ModifierTransaction valueexpr postings--ledgerPeriodicTransaction :: GenParser Char JournalContext PeriodicTransaction-ledgerPeriodicTransaction = do-  char '~' <?> "periodic transaction"-  many spacenonewline-  periodexpr <- restofline-  postings <- ledgerpostings-  return $ PeriodicTransaction periodexpr postings--ledgerHistoricalPrice :: GenParser Char JournalContext HistoricalPrice-ledgerHistoricalPrice = do-  char 'P' <?> "historical price"-  many spacenonewline-  date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate -- a time is ignored-  many1 spacenonewline-  symbol <- commoditysymbol-  many spacenonewline-  price <- someamount-  restofline-  return $ HistoricalPrice date symbol price+journalAddFile :: (FilePath,String) -> Journal -> Journal+journalAddFile f j@Journal{files=fs} = j{files=fs++[f]} -ledgerIgnoredPriceCommodity :: GenParser Char JournalContext JournalUpdate-ledgerIgnoredPriceCommodity = do-  char 'N' <?> "ignored-price commodity"+ledgerAccountBegin :: GenParser Char JournalContext JournalUpdate+ledgerAccountBegin = do+  string "account"   many1 spacenonewline-  commoditysymbol-  restofline+  parent <- ledgeraccountname+  newline+  pushParentAccount parent   return $ return id -ledgerCommodityConversion :: GenParser Char JournalContext JournalUpdate-ledgerCommodityConversion = do-  char 'C' <?> "commodity conversion"+ledgerAccountEnd :: GenParser Char JournalContext JournalUpdate+ledgerAccountEnd = do+  string "end"+  popParentAccount+  return (return id)++ledgerAlias :: GenParser Char JournalContext JournalUpdate+ledgerAlias = do+  string "alias"   many1 spacenonewline-  someamount-  many spacenonewline+  orig <- many1 $ noneOf "="   char '='-  many spacenonewline-  someamount-  restofline+  alias <- restofline+  addAccountAlias (accountNameWithoutPostingType $ strip orig+                  ,accountNameWithoutPostingType $ strip alias)   return $ return id +ledgerEndAliases :: GenParser Char JournalContext JournalUpdate+ledgerEndAliases = do+  string "end aliases"+  clearAccountAliases+  return (return id)+ ledgerTagDirective :: GenParser Char JournalContext JournalUpdate ledgerTagDirective = do   string "tag" <?> "tag directive"@@ -291,11 +279,10 @@  ledgerEndTagDirective :: GenParser Char JournalContext JournalUpdate ledgerEndTagDirective = do-  string "end tag" <?> "end tag directive"+  (string "end tag" <|> string "pop") <?> "end tag or pop directive"   restofline   return $ return id --- like ledgerAccountBegin, updates the JournalContext ledgerDefaultYear :: GenParser Char JournalContext JournalUpdate ledgerDefaultYear = do   char 'Y' <?> "default year"@@ -317,6 +304,54 @@   restofline   return $ return id +ledgerHistoricalPrice :: GenParser Char JournalContext HistoricalPrice+ledgerHistoricalPrice = do+  char 'P' <?> "historical price"+  many spacenonewline+  date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate -- a time is ignored+  many1 spacenonewline+  symbol <- commoditysymbol+  many spacenonewline+  price <- someamount+  restofline+  return $ HistoricalPrice date symbol price++ledgerIgnoredPriceCommodity :: GenParser Char JournalContext JournalUpdate+ledgerIgnoredPriceCommodity = do+  char 'N' <?> "ignored-price commodity"+  many1 spacenonewline+  commoditysymbol+  restofline+  return $ return id++ledgerCommodityConversion :: GenParser Char JournalContext JournalUpdate+ledgerCommodityConversion = do+  char 'C' <?> "commodity conversion"+  many1 spacenonewline+  someamount+  many spacenonewline+  char '='+  many spacenonewline+  someamount+  restofline+  return $ return id++ledgerModifierTransaction :: GenParser Char JournalContext ModifierTransaction+ledgerModifierTransaction = do+  char '=' <?> "modifier transaction"+  many spacenonewline+  valueexpr <- restofline+  postings <- ledgerpostings+  return $ ModifierTransaction valueexpr postings++ledgerPeriodicTransaction :: GenParser Char JournalContext PeriodicTransaction+ledgerPeriodicTransaction = do+  char '~' <?> "periodic transaction"+  many spacenonewline+  periodexpr <- restofline+  postings <- ledgerpostings+  return $ PeriodicTransaction periodexpr postings+ -- | Parse a (possibly unbalanced) ledger transaction. ledgerTransaction :: GenParser Char JournalContext Transaction ledgerTransaction = do@@ -332,6 +367,8 @@   postings <- ledgerpostings   return $ txnTieKnot $ Transaction date edate status code description comment md postings "" +-- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed. The year+-- may be omitted if a default year has already been set. ledgerdate :: GenParser Char JournalContext Day ledgerdate = do   -- hacky: try to ensure precise errors for invalid dates@@ -340,28 +377,48 @@   datestr <- many1 $ choice' [digit, datesepchar]   let dateparts = wordsBy (`elem` datesepchars) datestr   currentyear <- getYear-  let [y,m,d] = case (dateparts,currentyear) of-                  ([m,d],Just y)  -> [show y,m,d]-                  ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"-                  _               -> dateparts-      maybedate = fromGregorianValid (read y) (read m) (read d)+  [y,m,d] <- case (dateparts,currentyear) of+              ([m,d],Just y)  -> return [show y,m,d]+              ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"+              ([y,m,d],_)     -> return [y,m,d]+              _               -> fail $ "bad date: " ++ datestr+  let maybedate = fromGregorianValid (read y) (read m) (read d)   case maybedate of     Nothing   -> fail $ "bad date: " ++ datestr     Just date -> return date   <?> "full or partial date" +-- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format.  Any+-- timezone will be ignored; the time is treated as local time.  Fewer+-- digits are allowed, except in the timezone. The year may be omitted if+-- a default year has already been set. ledgerdatetime :: GenParser Char JournalContext LocalTime ledgerdatetime = do    day <- ledgerdate   many1 spacenonewline   h <- many1 digit+  let h' = read h+  guard $ h' >= 0 && h' <= 23   char ':'   m <- many1 digit-  s <- optionMaybe $ do-      char ':'-      many1 digit-  let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)-  return $ LocalTime day tod+  let m' = read m+  guard $ m' >= 0 && m' <= 59+  s <- optionMaybe $ char ':' >> many1 digit+  let s' = case s of Just sstr -> read sstr+                     Nothing   -> 0+  guard $ s' >= 0 && s' <= 59+  {- tz <- -}+  optionMaybe $ do+                   plusminus <- oneOf "-+"+                   d1 <- digit+                   d2 <- digit+                   d3 <- digit+                   d4 <- digit+                   return $ plusminus:d1:d2:d3:d4:""+  -- ltz <- liftIO $ getCurrentTimeZone+  -- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz+  -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')+  return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')  ledgereffectivedate :: Day -> GenParser Char JournalContext Day ledgereffectivedate actualdate = do@@ -433,8 +490,8 @@   many1 spacenonewline   status <- ledgerstatus   many spacenonewline-  account <- transactionaccountname-  let (ptype, account') = (postingTypeFromAccountName account, unbracket account)+  account <- modifiedaccountname+  let (ptype, account') = (accountNamePostingType account, unbracket account)   amount <- postingamount   many spacenonewline   comment <- ledgercomment <|> return ""@@ -442,9 +499,14 @@   md <- ledgermetadata   return (Posting status account' amount comment ptype md Nothing) --- qualify with the parent account from parsing context-transactionaccountname :: GenParser Char JournalContext AccountName-transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname+-- Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.+modifiedaccountname :: GenParser Char JournalContext AccountName+modifiedaccountname = do+  a <- ledgeraccountname+  prefix <- getParentAccount+  let prefixed = prefix `joinAccountNames` a+  aliases <- getAccountAliases+  return $ accountNameApplyAliases aliases prefixed  -- | Parse an account name. Account names may have single spaces inside -- them, and are terminated by two or more spaces. They should have one or@@ -668,16 +730,37 @@   ,"ledgerPeriodicTransaction" ~: do      assertParse (parseWithCtx nullctx ledgerPeriodicTransaction "~ (some period expr)\n some:postings  1\n") -  ,"ledgerExclamationDirective" ~: do-     assertParse (parseWithCtx nullctx ledgerExclamationDirective "!include /some/file.x\n")-     assertParse (parseWithCtx nullctx ledgerExclamationDirective "!account some:account\n")-     assertParse (parseWithCtx nullctx (ledgerExclamationDirective >> ledgerExclamationDirective) "!account a\n!end\n")+  ,"ledgerDirective" ~: do+     assertParse (parseWithCtx nullctx ledgerDirective "!include /some/file.x\n")+     assertParse (parseWithCtx nullctx ledgerDirective "account some:account\n")+     assertParse (parseWithCtx nullctx (ledgerDirective >> ledgerDirective) "!account a\nend\n")    ,"ledgercommentline" ~: do      assertParse (parseWithCtx nullctx ledgercommentline "; some comment \n")      assertParse (parseWithCtx nullctx ledgercommentline " \t; x\n")      assertParse (parseWithCtx nullctx ledgercommentline ";x") +  ,"ledgerdate" ~: do+     assertParse (parseWithCtx nullctx ledgerdate "2011/1/1")+     assertParseFailure (parseWithCtx nullctx ledgerdate "1/1")+     assertParse (parseWithCtx nullctx{ctxYear=Just 2011} ledgerdate "1/1")++  ,"ledgerdatetime" ~: do+      let p = do {t <- ledgerdatetime; eof; return t}+          bad = assertParseFailure . parseWithCtx nullctx p+          good = assertParse . parseWithCtx nullctx p+      bad "2011/1/1"+      bad "2011/1/1 24:00:00"+      bad "2011/1/1 00:60:00"+      bad "2011/1/1 00:00:60"+      good "2011/1/1 00:00"+      good "2011/1/1 23:59:59"+      good "2011/1/1 3:5:7"+      -- timezone is parsed but ignored+      let startofday = LocalTime (fromGregorian 2011 1 1) (TimeOfDay 0 0 (fromIntegral 0))+      assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00-0800") startofday+      assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00+1234") startofday+   ,"ledgerDefaultYear" ~: do      assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 2010\n")      assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 10001\n")@@ -699,6 +782,8 @@    ,"ledgerEndTagDirective" ~: do      assertParse (parseWithCtx nullctx ledgerEndTagDirective "end tag \n")+  ,"ledgerEndTagDirective" ~: do+     assertParse (parseWithCtx nullctx ledgerEndTagDirective "pop \n")    ,"ledgeraccountname" ~: do     assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c")

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-|  A reader for the timelog file format generated by timeclock.el.@@ -47,12 +46,16 @@        tests_Hledger_Read_TimelogReader ) where-import Control.Monad.Error (ErrorT(..))+import Control.Monad+import Control.Monad.Error+import Test.HUnit import Text.ParserCombinators.Parsec hiding (parse)+ import Hledger.Data import Hledger.Read.Utils-import Hledger.Read.JournalReader (ledgerExclamationDirective, ledgerHistoricalPrice,+import Hledger.Read.JournalReader (ledgerDirective, ledgerHistoricalPrice,                                    ledgerDefaultYear, emptyLine, ledgerdatetime)+import Hledger.Utils   reader :: Reader@@ -80,7 +83,7 @@       -- As all ledger line types can be distinguished by the first       -- character, excepting transactions versus empty (blank or       -- comment-only) lines, can use choice w/o try-      timelogItem = choice [ ledgerExclamationDirective+      timelogItem = choice [ ledgerDirective                           , liftM (return . addHistoricalPrice) ledgerHistoricalPrice                           , ledgerDefaultYear                           , emptyLine >> return (return id)

@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} {-| Utilities common to hledger journal readers. -}@@ -6,15 +7,17 @@ where  import Control.Monad.Error+import Data.List import System.Directory (getHomeDirectory) import System.FilePath(takeDirectory,combine) import System.Time (getClockTime) import Text.ParserCombinators.Parsec -import Hledger.Data.Types (Journal, JournalContext(..), Commodity, JournalUpdate)-import Hledger.Data.Utils+import Hledger.Data.Types+import Hledger.Utils+import Hledger.Data.Posting import Hledger.Data.Dates (getCurrentYear)-import Hledger.Data.Journal (nullctx, nulljournal, journalFinalise)+import Hledger.Data.Journal   juSequence :: [JournalUpdate] -> JournalUpdate@@ -49,8 +52,7 @@  pushParentAccount :: String -> GenParser tok JournalContext () pushParentAccount parent = updateState addParentAccount-    where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 }-          normalize = (++ ":") +    where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 }  popParentAccount :: GenParser tok JournalContext () popParentAccount = do ctx0 <- getState@@ -59,7 +61,16 @@                         (_:rest) -> setState $ ctx0 { ctxAccount = rest }  getParentAccount :: GenParser tok JournalContext String-getParentAccount = liftM (concat . reverse . ctxAccount) getState+getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState++addAccountAlias :: (AccountName,AccountName) -> GenParser tok JournalContext ()+addAccountAlias a = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})++getAccountAliases :: GenParser tok JournalContext [(AccountName,AccountName)]+getAccountAliases = liftM ctxAliases getState++clearAccountAliases :: GenParser tok JournalContext ()+clearAccountAliases = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})  -- | Convert a possibly relative, possibly tilde-containing file path to an absolute one. -- using the current directory from a parsec source position. ~username is not supported.

@@ -0,0 +1,595 @@+{-# LANGUAGE RecordWildCards #-}+{-|++Generate several common kinds of report from a journal, as \"*Report\" -+simple intermediate data structures intended to be easily rendered as+text, html, json, csv etc. by hledger commands, hamlet templates,+javascript, or whatever. This is under Hledger.Cli since it depends+on the command-line options, should move to hledger-lib later.++-}++module Hledger.Reports (+  ReportOpts(..),+  DisplayExp,+  FormatStr,+  defreportopts,+  dateSpanFromOpts,+  intervalFromOpts,+  clearedValueFromOpts,+  whichDateFromOpts,+  journalSelectingDateFromOpts,+  journalSelectingAmountFromOpts,+  optsToFilterSpec,+  -- * Entries report+  EntriesReport,+  EntriesReportItem,+  entriesReport,+  -- * Postings report+  PostingsReport,+  PostingsReportItem,+  postingsReport,+  mkpostingsReportItem, -- XXX for showPostingWithBalanceForVty in Hledger.Cli.Register+  -- * Transactions report+  TransactionsReport,+  TransactionsReportItem,+  triDate,+  triBalance,+  journalTransactionsReport,+  accountTransactionsReport,+  -- * Accounts report+  AccountsReport,+  AccountsReportItem,+  accountsReport,+  accountsReport2,+  isInteresting,+  -- * Tests+  tests_Hledger_Reports+)+where++import Control.Monad+import Data.List+import Data.Maybe+import Data.Ord+import Data.Time.Calendar+import Data.Tree+import Safe (headMay, lastMay)+import System.Console.CmdArgs  -- for defaults support+import Test.HUnit+import Text.ParserCombinators.Parsec+import Text.Printf++import Hledger.Data+import Hledger.Utils++-- report options, used in hledger-lib and above+data ReportOpts = ReportOpts {+     begin_          :: Maybe Day+    ,end_            :: Maybe Day+    ,period_         :: Maybe (Interval,DateSpan)+    ,cleared_        :: Bool+    ,uncleared_      :: Bool+    ,cost_           :: Bool+    ,depth_          :: Maybe Int+    ,display_        :: Maybe DisplayExp+    ,effective_      :: Bool+    ,empty_          :: Bool+    ,no_elide_       :: Bool+    ,real_           :: Bool+    ,flat_           :: Bool -- balance+    ,drop_           :: Int  -- balance+    ,no_total_       :: Bool -- balance+    ,daily_          :: Bool+    ,weekly_         :: Bool+    ,monthly_        :: Bool+    ,quarterly_      :: Bool+    ,yearly_         :: Bool+    ,format_         :: Maybe FormatStr+    ,patterns_       :: [String]+ } deriving (Show)++type DisplayExp = String+type FormatStr = String++defreportopts = ReportOpts+    def+    def+    def+    def+    def+    def+    def+    def+    def+    def+    def+    def+    def+    def+    def+    def+    def+    def+    def+    def+    def+    def++instance Default ReportOpts where def = defreportopts++-- | Figure out the date span we should report on, based on any+-- begin/end/period options provided. A period option will cause begin and+-- end options to be ignored.+dateSpanFromOpts :: Day -> ReportOpts -> DateSpan+dateSpanFromOpts _ ReportOpts{..} =+    case period_ of Just (_,span) -> span+                    Nothing -> DateSpan begin_ end_++-- | Figure out the reporting interval, if any, specified by the options.+-- --period overrides --daily overrides --weekly overrides --monthly etc.+intervalFromOpts :: ReportOpts -> Interval+intervalFromOpts ReportOpts{..} =+    case period_ of+      Just (interval,_) -> interval+      Nothing -> i+          where i | daily_ = Days 1+                  | weekly_ = Weeks 1+                  | monthly_ = Months 1+                  | quarterly_ = Quarters 1+                  | yearly_ = Years 1+                  | otherwise =  NoInterval++-- | Get a maybe boolean representing the last cleared/uncleared option if any.+clearedValueFromOpts :: ReportOpts -> Maybe Bool+clearedValueFromOpts ReportOpts{..} | cleared_   = Just True+                                    | uncleared_ = Just False+                                    | otherwise  = Nothing++-- | Detect which date we will report on, based on --effective.+whichDateFromOpts :: ReportOpts -> WhichDate+whichDateFromOpts ReportOpts{..} = if effective_ then EffectiveDate else ActualDate++-- | Convert this journal's transactions' primary date to either the+-- actual or effective date, as per options.+journalSelectingDateFromOpts :: ReportOpts -> Journal -> Journal+journalSelectingDateFromOpts opts = journalSelectingDate (whichDateFromOpts opts)++-- | Convert this journal's postings' amounts to the cost basis amounts if+-- specified by options.+journalSelectingAmountFromOpts :: ReportOpts -> Journal -> Journal+journalSelectingAmountFromOpts opts+    | cost_ opts = journalConvertAmountsToCost+    | otherwise = id++-- | Convert application options to the library's generic filter specification.+optsToFilterSpec :: ReportOpts -> Day -> FilterSpec+optsToFilterSpec opts@ReportOpts{..} d = FilterSpec {+                                datespan=dateSpanFromOpts d opts+                               ,cleared= clearedValueFromOpts opts+                               ,real=real_+                               ,empty=empty_+                               ,acctpats=apats+                               ,descpats=dpats+                               ,depth = depth_+                               }+    where (apats,dpats) = parsePatternArgs patterns_++-- | Gather filter pattern arguments into a list of account patterns and a+-- list of description patterns. We interpret pattern arguments as+-- follows: those prefixed with "desc:" are description patterns, all+-- others are account patterns; also patterns prefixed with "not:" are+-- negated. not: should come after desc: if both are used.+parsePatternArgs :: [String] -> ([String],[String])+parsePatternArgs args = (as, ds')+    where+      descprefix = "desc:"+      (ds, as) = partition (descprefix `isPrefixOf`) args+      ds' = map (drop (length descprefix)) ds++-------------------------------------------------------------------------------++-- | A journal entries report is a list of whole transactions as+-- originally entered in the journal (mostly). Used by eg hledger's print+-- command and hledger-web's journal entries view.+type EntriesReport = [EntriesReportItem]+type EntriesReportItem = Transaction++-- | Select transactions for an entries report.+entriesReport :: ReportOpts -> FilterSpec -> Journal -> EntriesReport+entriesReport opts fspec j = sortBy (comparing tdate) $ jtxns $ filterJournalTransactions fspec j'+    where+      j' = journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j++-------------------------------------------------------------------------------++-- | A postings report is a list of postings with a running total, a label+-- for the total field, and a little extra transaction info to help with rendering.+type PostingsReport = (String               -- label for the running balance column XXX remove+                      ,[PostingsReportItem] -- line items, one per posting+                      )+type PostingsReportItem = (Maybe (Day, String) -- transaction date and description if this is the first posting+                                 ,Posting      -- the posting+                                 ,MixedAmount  -- the running total after this posting+                                 )++-- | Select postings from the journal and add running balance and other+-- information to make a postings report. Used by eg hledger's register command.+postingsReport :: ReportOpts -> FilterSpec -> Journal -> PostingsReport+postingsReport opts fspec j = (totallabel, postingsReportItems ps nullposting startbal (+))+    where+      ps | interval == NoInterval = displayableps+         | otherwise              = summarisePostingsByInterval interval depth empty filterspan displayableps+      (precedingps, displayableps, _) = postingsMatchingDisplayExpr (display_ opts)+                                        $ depthClipPostings depth+                                        $ journalPostings+                                        $ filterJournalPostings fspec{depth=Nothing}+                                        $ journalSelectingDateFromOpts opts+                                        $ journalSelectingAmountFromOpts opts+                                        j+      startbal = sumPostings precedingps+      filterspan = datespan fspec+      (interval, depth, empty) = (intervalFromOpts opts, depth_ opts, empty_ opts)++totallabel = "Total"+balancelabel = "Balance"++-- | Generate postings report line items.+postingsReportItems :: [Posting] -> Posting -> MixedAmount -> (MixedAmount -> MixedAmount -> MixedAmount) -> [PostingsReportItem]+postingsReportItems [] _ _ _ = []+postingsReportItems (p:ps) pprev b sumfn = i:(postingsReportItems ps p b' sumfn)+    where+      i = mkpostingsReportItem isfirst p b'+      isfirst = ptransaction p /= ptransaction pprev+      b' = b `sumfn` pamount p++-- | Generate one postings report line item, from a flag indicating+-- whether to include transaction info, a posting, and the current running+-- balance.+mkpostingsReportItem :: Bool -> Posting -> MixedAmount -> PostingsReportItem+mkpostingsReportItem False p b = (Nothing, p, b)+mkpostingsReportItem True p b = (ds, p, b)+    where ds = case ptransaction p of Just (Transaction{tdate=da,tdescription=de}) -> Just (da,de)+                                      Nothing -> Just (nulldate,"")++-- | Date-sort and split a list of postings into three spans - postings matched+-- by the given display expression, and the preceding and following postings.+postingsMatchingDisplayExpr :: Maybe String -> [Posting] -> ([Posting],[Posting],[Posting])+postingsMatchingDisplayExpr d ps = (before, matched, after)+    where+      sorted = sortBy (comparing postingDate) ps+      (before, rest) = break (displayExprMatches d) sorted+      (matched, after) = span (displayExprMatches d) rest++-- | Does this display expression allow this posting to be displayed ?+-- Raises an error if the display expression can't be parsed.+displayExprMatches :: Maybe String -> Posting -> Bool+displayExprMatches Nothing  _ = True+displayExprMatches (Just d) p = (fromparse $ parsewith datedisplayexpr d) p++-- | Parse a hledger display expression, which is a simple date test like+-- "d>[DATE]" or "d<=[DATE]", and return a "Posting"-matching predicate.+datedisplayexpr :: GenParser Char st (Posting -> Bool)+datedisplayexpr = do+  char 'd'+  op <- compareop+  char '['+  (y,m,d) <- smartdate+  char ']'+  let date    = parsedate $ printf "%04s/%02s/%02s" y m d+      test op = return $ (`op` date) . postingDate+  case op of+    "<"  -> test (<)+    "<=" -> test (<=)+    "="  -> test (==)+    "==" -> test (==)+    ">=" -> test (>=)+    ">"  -> test (>)+    _    -> mzero+ where+  compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"]++-- | Clip the account names to the specified depth in a list of postings.+depthClipPostings :: Maybe Int -> [Posting] -> [Posting]+depthClipPostings depth = map (depthClipPosting depth)++-- | Clip a posting's account name to the specified depth.+depthClipPosting :: Maybe Int -> Posting -> Posting+depthClipPosting Nothing p = p+depthClipPosting (Just d) p@Posting{paccount=a} = p{paccount=clipAccountName d a}++-- XXX confusing, refactor++-- | Convert a list of postings into summary postings. Summary postings+-- are one per account per interval and aggregated to the specified depth+-- if any.+summarisePostingsByInterval :: Interval -> Maybe Int -> Bool -> DateSpan -> [Posting] -> [Posting]+summarisePostingsByInterval interval depth empty filterspan ps = concatMap summarisespan $ splitSpan interval reportspan+    where+      summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s)+      postingsinspan s = filter (isPostingInDateSpan s) ps+      dataspan = postingsDateSpan ps+      reportspan | empty = filterspan `orDatesFrom` dataspan+                 | otherwise = dataspan++-- | Given a date span (representing a reporting interval) and a list of+-- postings within it: aggregate the postings so there is only one per+-- account, and adjust their date/description so that they will render+-- as a summary for this interval.+--+-- As usual with date spans the end date is exclusive, but for display+-- purposes we show the previous day as end date, like ledger.+--+-- When a depth argument is present, postings to accounts of greater+-- depth are aggregated where possible.+--+-- The showempty flag includes spans with no postings and also postings+-- with 0 amount.+summarisePostingsInDateSpan :: DateSpan -> Maybe Int -> Bool -> [Posting] -> [Posting]+summarisePostingsInDateSpan (DateSpan b e) depth showempty ps+    | null ps && (isNothing b || isNothing e) = []+    | null ps && showempty = [summaryp]+    | otherwise = summaryps'+    where+      summaryp = summaryPosting b' ("- "++ showDate (addDays (-1) e'))+      b' = fromMaybe (maybe nulldate postingDate $ headMay ps) b+      e' = fromMaybe (maybe (addDays 1 nulldate) postingDate $ lastMay ps) e+      summaryPosting date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}}++      summaryps' = (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps+      summaryps = [summaryp{paccount=a,pamount=balancetoshowfor a} | a <- clippedanames]+      anames = sort $ nub $ map paccount ps+      -- aggregate balances by account, like journalToLedger, then do depth-clipping+      (_,_,exclbalof,inclbalof) = groupPostings ps+      clippedanames = nub $ map (clipAccountName d) anames+      isclipped a = accountNameLevel a >= d+      d = fromMaybe 99999 $ depth+      balancetoshowfor a =+          (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a)++-------------------------------------------------------------------------------++-- | A transactions report includes a list of transactions+-- (posting-filtered and unfiltered variants), a running balance, and some+-- other information helpful for rendering a register view (a flag+-- indicating multiple other accounts and a display string describing+-- them) with or without a notion of current account(s).+type TransactionsReport = (String                   -- label for the balance column, eg "balance" or "total"+                          ,[TransactionsReportItem] -- line items, one per transaction+                          )+type TransactionsReportItem = (Transaction -- the corresponding transaction+                              ,Transaction -- the transaction with postings to the current account(s) removed+                              ,Bool        -- is this a split, ie more than one other account posting+                              ,String      -- a display string describing the other account(s), if any+                              ,MixedAmount -- the amount posted to the current account(s) (or total amount posted)+                              ,MixedAmount -- the running balance for the current account(s) after this transaction+                              )++triDate (t,_,_,_,_,_) = tdate t+triBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0"+                                           (Amount{quantity=q}):_ -> show q++-- | Select transactions from the whole journal for a transactions report,+-- with no \"current\" account. The end result is similar to+-- "postingsReport" except it uses matchers and transaction-based report+-- items and the items are most recent first. Used by eg hledger-web's+-- journal view.+journalTransactionsReport :: ReportOpts -> Journal -> Matcher -> TransactionsReport+journalTransactionsReport _ Journal{jtxns=ts} m = (totallabel, items)+   where+     ts' = sortBy (comparing tdate) $ filter (not . null . tpostings) $ map (filterTransactionPostings m) ts+     items = reverse $ accountTransactionsReportItems m Nothing nullmixedamt id ts'+     -- XXX items' first element should be the full transaction with all postings++-------------------------------------------------------------------------------++-- | Select transactions within one or more \"current\" accounts, and make a+-- transactions report relative to those account(s). This means:+--+-- 1. it shows transactions from the point of view of the current account(s).+--    The transaction amount is the amount posted to the current account(s).+--    The other accounts' names are provided. +--+-- 2. With no transaction filtering in effect other than a start date, it+--    shows the accurate historical running balance for the current account(s).+--    Otherwise it shows a running total starting at 0.+--+-- Currently, reporting intervals are not supported, and report items are+-- most recent first. Used by eg hledger-web's account register view.+--+accountTransactionsReport :: ReportOpts -> Journal -> Matcher -> Matcher -> TransactionsReport+accountTransactionsReport opts j m thisacctmatcher = (label, items)+ where+     -- transactions affecting this account, in date order+     ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctmatcher) $ jtxns $+          journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j+     -- starting balance: if we are filtering by a start date and nothing else,+     -- the sum of postings to this account before that date; otherwise zero.+     (startbal,label) | matcherIsNull m                           = (nullmixedamt,        balancelabel)+                      | matcherIsStartDateOnly (effective_ opts) m = (sumPostings priorps, balancelabel)+                      | otherwise                                 = (nullmixedamt,        totallabel)+                      where+                        priorps = -- ltrace "priorps" $+                                  filter (matchesPosting+                                          (-- ltrace "priormatcher" $+                                           MatchAnd [thisacctmatcher, tostartdatematcher]))+                                         $ transactionsPostings ts+                        tostartdatematcher = MatchDate (DateSpan Nothing startdate)+                        startdate = matcherStartDate (effective_ opts) m+     items = reverse $ accountTransactionsReportItems m (Just thisacctmatcher) startbal negate ts++-- | Generate transactions report items from a list of transactions,+-- using the provided query and current account matchers, starting balance,+-- sign-setting function and balance-summing function.+accountTransactionsReportItems :: Matcher -> Maybe Matcher -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem]+accountTransactionsReportItems _ _ _ _ [] = []+accountTransactionsReportItems matcher thisacctmatcher bal signfn (t:ts) =+    -- This is used for both accountTransactionsReport and journalTransactionsReport,+    -- which makes it a bit overcomplicated+    case i of Just i' -> i':is+              Nothing -> is+    where+      tmatched@Transaction{tpostings=psmatched} = filterTransactionPostings matcher t+      (psthisacct,psotheracct) = case thisacctmatcher of Just m  -> partition (matchesPosting m) psmatched+                                                         Nothing -> ([],psmatched)+      numotheraccts = length $ nub $ map paccount psotheracct+      amt = sum $ map pamount psotheracct+      acct | isNothing thisacctmatcher = summarisePostings psmatched -- journal register+           | numotheraccts == 0 = "transfer between " ++ summarisePostingAccounts psthisacct+           | otherwise          = prefix              ++ summarisePostingAccounts psotheracct+           where prefix = maybe "" (\b -> if b then "from " else "to ") $ isNegativeMixedAmount amt+      (i,bal') = case psmatched of+           [] -> (Nothing,bal)+           _  -> (Just (t, tmatched, numotheraccts > 1, acct, a, b), b)+                 where+                  a = signfn amt+                  b = bal + a+      is = accountTransactionsReportItems matcher thisacctmatcher bal' signfn ts++-- | Generate a short readable summary of some postings, like+-- "from (negatives) to (positives)".+summarisePostings :: [Posting] -> String+summarisePostings ps =+    case (summarisePostingAccounts froms, summarisePostingAccounts tos) of+       ("",t) -> "to "++t+       (f,"") -> "from "++f+       (f,t)  -> "from "++f++" to "++t+    where+      (froms,tos) = partition (fromMaybe False . isNegativeMixedAmount . pamount) ps++-- | Generate a simplified summary of some postings' accounts.+summarisePostingAccounts :: [Posting] -> String+summarisePostingAccounts = intercalate ", " . map accountLeafName . nub . map paccount++filterTransactionPostings :: Matcher -> Transaction -> Transaction+filterTransactionPostings m t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps}++-------------------------------------------------------------------------------++-- | An accounts report is a list of account names (full and short+-- variants) with their balances, appropriate indentation for rendering as+-- a hierarchy, and grand total.+type AccountsReport = ([AccountsReportItem] -- line items, one per account+                      ,MixedAmount          -- total balance of all accounts+                      )+type AccountsReportItem = (AccountName  -- full account name+                          ,AccountName  -- short account name for display (the leaf name, prefixed by any boring parents immediately above)+                          ,Int          -- how many steps to indent this account (0-based account depth excluding boring parents)+                          ,MixedAmount) -- account balance, includes subs unless --flat is present++-- | Select accounts, and get their balances at the end of the selected+-- period, and misc. display information, for an accounts report. Used by+-- eg hledger's balance command.+accountsReport :: ReportOpts -> FilterSpec -> Journal -> AccountsReport+accountsReport opts filterspec j = accountsReport' opts j (journalToLedger filterspec)++-- | Select accounts, and get their balances at the end of the selected+-- period, and misc. display information, for an accounts report. Like+-- "accountsReport" but uses the new matchers. Used by eg hledger-web's+-- accounts sidebar.+accountsReport2 :: ReportOpts -> Matcher -> Journal -> AccountsReport+accountsReport2 opts matcher j = accountsReport' opts j (journalToLedger2 matcher)++-- Accounts report helper.+accountsReport' :: ReportOpts -> Journal -> (Journal -> Ledger) -> AccountsReport+accountsReport' opts j jtol = (items, total)+    where+      items = map mkitem interestingaccts+      interestingaccts | no_elide_ opts = acctnames+                       | otherwise = filter (isInteresting opts l) acctnames+      acctnames = sort $ tail $ flatten $ treemap aname accttree+      accttree = ledgerAccountTree (fromMaybe 99999 $ depth_ opts) l+      total = sum $ map abalance $ ledgerTopAccounts l+      l =  jtol $ journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j++      -- | Get data for one balance report line item.+      mkitem :: AccountName -> AccountsReportItem+      mkitem a = (a, adisplay, indent, abal)+          where+            adisplay | flat_ opts = a+                     | otherwise = accountNameFromComponents $ reverse (map accountLeafName ps) ++ [accountLeafName a]+                where ps = takeWhile boring parents where boring = not . (`elem` interestingparents)+            indent | flat_ opts = 0+                   | otherwise = length interestingparents+            interestingparents = filter (`elem` interestingaccts) parents+            parents = parentAccountNames a+            abal | flat_ opts = exclusiveBalance acct+                 | otherwise = abalance acct+                 where acct = ledgerAccount l a++exclusiveBalance :: Account -> MixedAmount+exclusiveBalance = sumPostings . apostings++-- | Is the named account considered interesting for this ledger's accounts report,+-- following the eliding style of ledger's balance command ?+isInteresting :: ReportOpts -> Ledger -> AccountName -> Bool+isInteresting opts l a | flat_ opts = isInterestingFlat opts l a+                       | otherwise = isInterestingIndented opts l a++isInterestingFlat :: ReportOpts -> Ledger -> AccountName -> Bool+isInterestingFlat opts l a = notempty || emptyflag+    where+      acct = ledgerAccount l a+      notempty = not $ isZeroMixedAmount $ exclusiveBalance acct+      emptyflag = empty_ opts++isInterestingIndented :: ReportOpts -> Ledger -> AccountName -> Bool+isInterestingIndented opts l a+    | numinterestingsubs==1 && not atmaxdepth = notlikesub+    | otherwise = notzero || emptyflag+    where+      atmaxdepth = isJust d && Just (accountNameLevel a) == d where d = depth_ opts+      emptyflag = empty_ opts+      acct = ledgerAccount l a+      notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct+      notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumPostings $ apostings acct+      numinterestingsubs = length $ filter isInterestingTree subtrees+          where+            isInterestingTree = treeany (isInteresting opts l . aname)+            subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a++-------------------------------------------------------------------------------++tests_Hledger_Reports :: Test+tests_Hledger_Reports = TestList+ [++  "summarisePostingsByInterval" ~: do+    summarisePostingsByInterval (Quarters 1) Nothing False (DateSpan Nothing Nothing) [] ~?= []++  -- ,"summarisePostingsInDateSpan" ~: do+  --   let gives (b,e,depth,showempty,ps) =+  --           (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`)+  --   let ps =+  --           [+  --            nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]}+  --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=Mixed [dollars 2]}+  --           ,nullposting{lpdescription="desc",lpaccount="expenses:food",          lpamount=Mixed [dollars 4]}+  --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=Mixed [dollars 8]}+  --           ]+  --   ("2008/01/01","2009/01/01",0,9999,False,[]) `gives`+  --    []+  --   ("2008/01/01","2009/01/01",0,9999,True,[]) `gives`+  --    [+  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31"}+  --    ]+  --   ("2008/01/01","2009/01/01",0,9999,False,ts) `gives`+  --    [+  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",          lpamount=Mixed [dollars 4]}+  --    ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining",   lpamount=Mixed [dollars 10]}+  --    ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]}+  --    ]+  --   ("2008/01/01","2009/01/01",0,2,False,ts) `gives`+  --    [+  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [dollars 15]}+  --    ]+  --   ("2008/01/01","2009/01/01",0,1,False,ts) `gives`+  --    [+  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [dollars 15]}+  --    ]+  --   ("2008/01/01","2009/01/01",0,0,False,ts) `gives`+  --    [+  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [dollars 15]}+  --    ]++ ]

@@ -0,0 +1,427 @@+{-|++Standard imports and utilities which are useful everywhere, or needed low+in the module hierarchy. This is the bottom of hledger's module graph.++-}++module Hledger.Utils (---- provide these frequently used modules - or not, for clearer api:+                          -- module Control.Monad,+                          -- module Data.List,+                          -- module Data.Maybe,+                          -- module Data.Time.Calendar,+                          -- module Data.Time.Clock,+                          -- module Data.Time.LocalTime,+                          -- module Data.Tree,+                          -- module Debug.Trace,+                          -- module Text.RegexPR,+                          -- module Test.HUnit,+                          -- module Text.Printf,+                          ---- all of this one:+                          module Hledger.Utils,+                          Debug.Trace.trace+                          ---- and this for i18n - needs to be done in each module I think:+                          -- module Hledger.Utils.UTF8+                          )+where+import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded)+import Data.Char+import Data.List+import Data.Maybe+import Data.Time.Clock+import Data.Time.LocalTime+import Data.Tree+import Debug.Trace+import System.Info (os)+import Test.HUnit+import Text.ParserCombinators.Parsec+import Text.Printf+import Text.RegexPR+-- import qualified Data.Map as Map+-- +-- import Prelude hiding (readFile,writeFile,getContents,putStr,putStrLn)+-- import Hledger.Utils.UTF8++-- strings++lowercase = map toLower+uppercase = map toUpper++strip = lstrip . rstrip+lstrip = dropWhile (`elem` " \t")+rstrip = reverse . lstrip . reverse++elideLeft width s =+    if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s++elideRight width s =+    if length s > width then take (width - 2) s ++ ".." else s++underline :: String -> String+underline s = s' ++ replicate (length s) '-' ++ "\n"+    where s'+            | last s == '\n' = s+            | otherwise = s ++ "\n"++-- | Wrap a string in single quotes, and \-prefix any embedded single+-- quotes, if it contains whitespace and is not already single- or+-- double-quoted.+quoteIfSpaced :: String -> String+quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s+                | not $ any (`elem` s) whitespacechars = s+                | otherwise = "'"++escapeSingleQuotes s++"'"+                  where escapeSingleQuotes = regexReplace "'" "\'"++-- | Quote-aware version of words - don't split on spaces which are inside quotes.+-- NB correctly handles "a'b" but not "''a''".+words' :: String -> [String]+words' = map stripquotes . fromparse . parsewith p+    where+      p = do ss <- (quotedPattern <|> pattern) `sepBy` many1 spacenonewline+             -- eof+             return ss+      pattern = many (noneOf whitespacechars)+      quotedPattern = between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\""++-- | Quote-aware version of unwords - single-quote strings which contain whitespace+unwords' :: [String] -> String+unwords' = unwords . map singleQuoteIfNeeded++singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"+                      | otherwise = s++whitespacechars = " \t\n\r"++-- | Strip one matching pair of single or double quotes on the ends of a string.+stripquotes :: String -> String+stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s++isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\''+isSingleQuoted _ = False++isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"'+isDoubleQuoted _ = False++unbracket :: String -> String+unbracket s+    | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s+    | otherwise = s++-- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded.+concatTopPadded :: [String] -> String+concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded+    where+      lss = map lines strs+      h = maximum $ map length lss+      ypad ls = replicate (difforzero h (length ls)) "" ++ ls+      xpad ls = map (padleft w) ls where w | null ls = 0+                                           | otherwise = maximum $ map length ls+      padded = map (xpad . ypad) lss++-- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.+concatBottomPadded :: [String] -> String+concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded+    where+      lss = map lines strs+      h = maximum $ map length lss+      ypad ls = ls ++ replicate (difforzero h (length ls)) ""+      xpad ls = map (padleft w) ls where w | null ls = 0+                                           | otherwise = maximum $ map length ls+      padded = map (xpad . ypad) lss++-- | Compose strings vertically and right-aligned.+vConcatRightAligned :: [String] -> String+vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss+    where+      showfixedwidth = printf (printf "%%%ds" width)+      width = maximum $ map length ss++-- | Convert a multi-line string to a rectangular string top-padded to the specified height.+padtop :: Int -> String -> String+padtop h s = intercalate "\n" xpadded+    where+      ls = lines s+      sh = length ls+      sw | null ls = 0+         | otherwise = maximum $ map length ls+      ypadded = replicate (difforzero h sh) "" ++ ls+      xpadded = map (padleft sw) ypadded++-- | Convert a multi-line string to a rectangular string bottom-padded to the specified height.+padbottom :: Int -> String -> String+padbottom h s = intercalate "\n" xpadded+    where+      ls = lines s+      sh = length ls+      sw | null ls = 0+         | otherwise = maximum $ map length ls+      ypadded = ls ++ replicate (difforzero h sh) ""+      xpadded = map (padleft sw) ypadded++-- | Convert a multi-line string to a rectangular string left-padded to the specified width.+padleft :: Int -> String -> String+padleft w "" = concat $ replicate w " "+padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s++-- | Convert a multi-line string to a rectangular string right-padded to the specified width.+padright :: Int -> String -> String+padright w "" = concat $ replicate w " "+padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s++-- | Clip a multi-line string to the specified width and height from the top left.+cliptopleft :: Int -> Int -> String -> String+cliptopleft w h = intercalate "\n" . take h . map (take w) . lines++-- | Clip and pad a multi-line string to fill the specified width and height.+fitto :: Int -> Int -> String -> String+fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline+    where+      rows = map (fit w) $ lines s+      fit w = take w . (++ repeat ' ')+      blankline = replicate w ' '++-- encoded platform strings++-- | A platform string is a string value from or for the operating system,+-- such as a file path or command-line argument (or environment variable's+-- name or value ?). On some platforms (such as unix) these are not real+-- unicode strings but have some encoding such as UTF-8. This alias does+-- no type enforcement but aids code clarity.+type PlatformString = String++-- | Convert a possibly encoded platform string to a real unicode string.+-- We decode the UTF-8 encoding recommended for unix systems+-- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)+-- and leave anything else unchanged.+fromPlatformString :: PlatformString -> String+fromPlatformString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s++-- | Convert a unicode string to a possibly encoded platform string.+-- On unix we encode with the recommended UTF-8+-- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)+-- and elsewhere we leave it unchanged.+toPlatformString :: String -> PlatformString+toPlatformString = case os of+                     "unix" -> UTF8.encodeString+                     "linux" -> UTF8.encodeString+                     "darwin" -> UTF8.encodeString+                     _ -> id++-- | A version of error that's better at displaying unicode.+error' :: String -> a+error' = error . toPlatformString++-- | A version of userError that's better at displaying unicode.+userError' :: String -> IOError+userError' = userError . toPlatformString++-- math++difforzero :: (Num a, Ord a) => a -> a -> a+difforzero a b = maximum [(a - b), 0]++-- regexps++-- regexMatch :: String -> String -> MatchFun Maybe+regexMatch r s = matchRegexPR r s++-- regexMatchCI :: String -> String -> MatchFun Maybe+regexMatchCI r s = regexMatch (regexToCaseInsensitive r) s++regexMatches :: String -> String -> Bool+regexMatches r s = isJust $ matchRegexPR r s++regexMatchesCI :: String -> String -> Bool+regexMatchesCI r s = regexMatches (regexToCaseInsensitive r) s++containsRegex = regexMatchesCI++regexReplace :: String -> String -> String -> String+regexReplace r repl s = gsubRegexPR r repl s++regexReplaceCI :: String -> String -> String -> String+regexReplaceCI r s = regexReplace (regexToCaseInsensitive r) s++regexReplaceBy :: String -> (String -> String) -> String -> String+regexReplaceBy r replfn s = gsubRegexPRBy r replfn s++regexToCaseInsensitive :: String -> String+regexToCaseInsensitive r = "(?i)"++ r++-- lists++splitAtElement :: Eq a => a -> [a] -> [[a]]+splitAtElement e l = +    case dropWhile (e==) l of+      [] -> []+      l' -> first : splitAtElement e rest+        where+          (first,rest) = break (e==) l'++-- trees++root = rootLabel+subs = subForest+branches = subForest++-- | List just the leaf nodes of a tree+leaves :: Tree a -> [a]+leaves (Node v []) = [v]+leaves (Node _ branches) = concatMap leaves branches++-- | get the sub-tree rooted at the first (left-most, depth-first) occurrence+-- of the specified node value+subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a)+subtreeat v t+    | root t == v = Just t+    | otherwise = subtreeinforest v $ subs t++-- | get the sub-tree for the specified node value in the first tree in+-- forest in which it occurs.+subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a)+subtreeinforest _ [] = Nothing+subtreeinforest v (t:ts) = case (subtreeat v t) of+                             Just t' -> Just t'+                             Nothing -> subtreeinforest v ts+          +-- | remove all nodes past a certain depth+treeprune :: Int -> Tree a -> Tree a+treeprune 0 t = Node (root t) []+treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t)++-- | apply f to all tree nodes+treemap :: (a -> b) -> Tree a -> Tree b+treemap f t = Node (f $ root t) (map (treemap f) $ branches t)++-- | remove all subtrees whose nodes do not fulfill predicate+treefilter :: (a -> Bool) -> Tree a -> Tree a+treefilter f t = Node +                 (root t) +                 (map (treefilter f) $ filter (treeany f) $ branches t)+    +-- | is predicate true in any node of tree ?+treeany :: (a -> Bool) -> Tree a -> Bool+treeany f t = f (root t) || any (treeany f) (branches t)+    +-- treedrop -- remove the leaves which do fulfill predicate. +-- treedropall -- do this repeatedly.++-- | show a compact ascii representation of a tree+showtree :: Show a => Tree a -> String+showtree = unlines . filter (regexMatches "[^ \\|]") . lines . drawTree . treemap show++-- | show a compact ascii representation of a forest+showforest :: Show a => Forest a -> String+showforest = concatMap showtree++-- debugging++-- | trace (print on stdout at runtime) a showable expression+-- (for easily tracing in the middle of a complex expression)+strace :: Show a => a -> a+strace a = trace (show a) a++-- | labelled trace - like strace, with a label prepended+ltrace :: Show a => String -> a -> a+ltrace l a = trace (l ++ ": " ++ show a) a++-- | monadic trace - like strace, but works as a standalone line in a monad+mtrace :: (Monad m, Show a) => a -> m a+mtrace a = strace a `seq` return a++-- | trace an expression using a custom show function+tracewith :: (a -> String) -> a -> a+tracewith f e = trace (f e) e++-- parsing++-- | Backtracking choice, use this when alternatives share a prefix.+-- Consumes no input if all choices fail.+choice' :: [GenParser tok st a] -> GenParser tok st a+choice' = choice . map Text.ParserCombinators.Parsec.try++parsewith :: Parser a -> String -> Either ParseError a+parsewith p = parse p ""++parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a+parseWithCtx ctx p = runParser p ctx ""++fromparse :: Either ParseError a -> a+fromparse = either parseerror id++parseerror :: ParseError -> a+parseerror e = error' $ showParseError e++showParseError :: ParseError -> String+showParseError e = "parse error at " ++ show e++showDateParseError :: ParseError -> String+showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)++nonspace :: GenParser Char st Char+nonspace = satisfy (not . isSpace)++spacenonewline :: GenParser Char st Char+spacenonewline = satisfy (`elem` " \v\f\t")++restofline :: GenParser Char st String+restofline = anyChar `manyTill` newline++-- time++getCurrentLocalTime :: IO LocalTime+getCurrentLocalTime = do+  t <- getCurrentTime+  tz <- getCurrentTimeZone+  return $ utcToLocalTime tz t++-- testing++-- | Get a Test's label, or the empty string.+tname :: Test -> String+tname (TestLabel n _) = n+tname _ = ""++-- | Flatten a Test containing TestLists into a list of single tests.+tflatten :: Test -> [Test]+tflatten (TestLabel _ t@(TestList _)) = tflatten t+tflatten (TestList ts) = concatMap tflatten ts+tflatten t = [t]++-- | Filter TestLists in a Test, recursively, preserving the structure.+tfilter :: (Test -> Bool) -> Test -> Test+tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts)+tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts+tfilter _ t = t++-- | Simple way to assert something is some expected value, with no label.+is :: (Eq a, Show a) => a -> a -> Assertion+a `is` e = assertEqual "" e a++-- | Assert a parse result is successful, printing the parse error on failure.+assertParse :: (Either ParseError a) -> Assertion+assertParse parse = either (assertFailure.show) (const (return ())) parse++-- | Assert a parse result is successful, printing the parse error on failure.+assertParseFailure :: (Either ParseError a) -> Assertion+assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse++-- | Assert a parse result is some expected value, printing the parse error on failure.+assertParseEqual :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion+assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse++printParseError :: (Show a) => a -> IO ()+printParseError e = do putStr "parse error at "; print e++-- misc++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _        = False++isRight :: Either a b -> Bool+isRight = not . isLeft++-- | Apply a function the specified number of times. Possibly uses O(n) stack ?+applyN :: Int -> (a -> a) -> a -> a+applyN n f = (!! n) . iterate f

@@ -0,0 +1,87 @@+{-+From pandoc, slightly extended. Example usage:++ import Prelude hiding (readFile,writeFile,getContents,putStr,putStrLn)+ import Hledger.Utils.UTF8 (readFile,writeFile,getContents,putStr,putStrLn)+++----------------------------------------------------------------------+Copyright (C) 2010 John MacFarlane <jgm@berkeley.edu>++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+-}++{- |+   Module      : Text.Pandoc.UTF8+   Copyright   : Copyright (C) 2010 John MacFarlane+   License     : GNU GPL, version 2 or above ++   Maintainer  : John MacFarlane <jgm@berkeley.edu>+   Stability   : alpha+   Portability : portable++UTF-8 aware string IO functions that will work with GHC 6.10 or 6.12.+-}+module Hledger.Utils.UTF8 ( readFile+                         , writeFile+                         , appendFile+                         , getContents+                         , hGetContents+                         , putStr+                         , putStrLn+                         , hPutStr+                         , hPutStrLn+                         )++where+import qualified Data.ByteString.Lazy as B+import Data.ByteString.Lazy.UTF8 (toString, fromString)+import Prelude hiding (readFile, writeFile, appendFile, getContents, putStr, putStrLn)+import System.IO (Handle)+import Control.Monad (liftM)++bom :: B.ByteString+bom = B.pack [0xEF, 0xBB, 0xBF]++stripBOM :: B.ByteString -> B.ByteString+stripBOM s | bom `B.isPrefixOf` s = B.drop 3 s+stripBOM s = s++readFile :: FilePath -> IO String+readFile = liftM (toString . stripBOM) . B.readFile++writeFile :: FilePath -> String -> IO ()+writeFile f = B.writeFile f . fromString++appendFile :: FilePath -> String -> IO ()+appendFile f = B.appendFile f . fromString++getContents :: IO String+getContents = liftM (toString . stripBOM) B.getContents++hGetContents :: Handle -> IO String+hGetContents h = liftM (toString . stripBOM) (B.hGetContents h)++putStr :: String -> IO ()+putStr = B.putStr . fromString++putStrLn :: String -> IO ()+putStrLn = B.putStrLn . fromString++hPutStr :: Handle -> String -> IO ()+hPutStr h = B.hPutStr h . fromString++hPutStrLn :: Handle -> String -> IO ()+hPutStrLn h s = hPutStr h (s ++ "\n")

@@ -1,4 +1,2 @@-#!/usr/bin/env runhaskell import Distribution.Simple- main = defaultMain

@@ -1,11 +1,14 @@ name:           hledger-lib-version: 0.14+version: 0.15 category:       Finance-synopsis:       Reusable types and utilities for the hledger accounting tool and financial apps in general.+synopsis:       Core data types, parsers and utilities for the hledger accounting tool. description:-                hledger is a haskell port and friendly fork of John Wiegley's ledger accounting tool.-                This package provides core data types, parsers and utilities used by the hledger tools.-                It also aims to be a useful library for building h/ledger-compatible tools or unrelated financial apps in haskell.+                hledger is a library and set of user tools for working+                with financial data (or anything that can be tracked in a+                double-entry accounting ledger.) It is a haskell port and+                friendly fork of John Wiegley's Ledger. hledger provides+                command-line, curses and web interfaces, and aims to be a+                reliable, practical tool for daily use.  license:        GPL license-file:   LICENSE@@ -14,7 +17,7 @@ homepage:       http://hledger.org bug-reports:    http://code.google.com/p/hledger/issues stability:      beta-tested-with:    GHC==6.10+tested-with:    GHC==6.12, GHC==7.0 cabal-version:  >= 1.6 build-type:     Simple -- data-dir:       data@@ -29,6 +32,7 @@   -- should set patchlevel here as in Makefile   cpp-options:    -DPATCHLEVEL=0   exposed-modules:+                  Hledger                   Hledger.Data                   Hledger.Data.Account                   Hledger.Data.AccountName@@ -38,18 +42,21 @@                   Hledger.Data.Transaction                   Hledger.Data.Journal                   Hledger.Data.Ledger+                  Hledger.Data.Matching                   Hledger.Data.Posting                   Hledger.Data.TimeLog                   Hledger.Data.Types-                  Hledger.Data.Utils-                  Hledger.Data.UTF8                   Hledger.Read-                  Hledger.Read.Utils                   Hledger.Read.JournalReader                   Hledger.Read.TimelogReader+                  Hledger.Read.Utils+                  Hledger.Reports+                  Hledger.Utils+                  Hledger.Utils.UTF8   Build-Depends:                   base >= 3 && < 5                  ,bytestring+                 ,cmdargs >= 0.8   && < 0.9                  ,containers                  ,directory                  ,filepath