hledger-lib 0.23.3 → 0.24

raw patch · 29 files changed

+1743/−1033 lines, 29 filesdep +Decimaldep +arraydep +blaze-markupdep ~parsecPVP ok

version bump matches the API change (PVP)

Dependencies added: Decimal, array, blaze-markup

Dependency ranges changed: parsec

API changes (from Hackage documentation)

Files

• CHANGES +18/−1
• Hledger/Data.hs +1/−1
• Hledger/Data/Account.hs +2/−2
• Hledger/Data/AccountName.hs +12/−4
• Hledger/Data/Amount.hs +230/−184
• Hledger/Data/Commodity.hs +2/−2
• Hledger/Data/Dates.hs +92/−35
• Hledger/Data/Journal.hs +87/−37
• Hledger/Data/Ledger.hs +1/−1
• Hledger/Data/OutputFormat.hs +7/−6
• Hledger/Data/Posting.hs +21/−11
• Hledger/Data/RawOptions.hs +1/−1
• Hledger/Data/TimeLog.hs +17/−16
• Hledger/Data/Transaction.hs +32/−26
• Hledger/Data/Types.hs +44/−10
• Hledger/Query.hs +97/−39
• Hledger/Read.hs +27/−19
• Hledger/Read/CsvReader.hs +97/−51
• Hledger/Read/JournalReader.hs +245/−170
• Hledger/Read/TimelogReader.hs +14/−11
• Hledger/Reports/BalanceReport.hs +41/−31
• Hledger/Reports/MultiBalanceReports.hs +19/−19
• Hledger/Reports/PostingsReport.hs +80/−59
• Hledger/Reports/ReportOptions.hs +25/−6
• Hledger/Reports/TransactionsReports.hs +114/−66
• Hledger/Utils.hs +44/−216
• Hledger/Utils/Debug.hs +205/−0
• Hledger/Utils/Regex.hs +139/−0
• hledger-lib.cabal +29/−9

@@ -1,4 +1,21 @@-API-ish changes in hledger-lib. For user-visible changes, see the hledger changelog.+API-ish changes in hledger-lib. For user-visible changes, see hledger.++0.24 (unreleased)++- fix combineJournalUpdates folding order+- fix a regexReplaceCI bug+- fix a splitAtElement bug with adjacent separators+- mostly replace slow regexpr with regex-tdfa (fixes #189)+- use the modern Text.Parsec API+- allow transformers 0.4*+- regexReplace now supports backreferences+- Transactions now remember their parse location in the journal file+- export Regexp types, disambiguate CsvReader's similarly-named type+- export failIfInvalidMonth/Day (fixes #216)+- track the commodity of zero amounts when possible+  (useful eg for hledger-web's multi-commodity charts)+- show posting dates in debug output+- more debug helpers  0.23.3 (2014/9/12) 

@@ -1,4 +1,4 @@-{-| +{-|  The Hledger.Data library allows parsing and querying of C++ ledger-style journal files.  It generally provides a compatible subset of C++ ledger's

@@ -115,7 +115,7 @@  -- | Remove all subaccounts below a certain depth. clipAccounts :: Int -> Account -> Account-clipAccounts 0 a = a{asubs=[]} +clipAccounts 0 a = a{asubs=[]} clipAccounts d a = a{asubs=subs}     where       subs = map (clipAccounts (d-1)) $ asubs a@@ -125,7 +125,7 @@ clipAccountsAndAggregate :: Int -> [Account] -> [Account] clipAccountsAndAggregate d as = combined     where-      clipped  = [a{aname=clipAccountName d $ aname a} | a <- as]+      clipped  = [a{aname=clipOrEllipsifyAccountName d $ aname a} | a <- as]       combined = [a{aebalance=sum (map aebalance same)}                   | same@(a:_) <- groupBy (\a1 a2 -> aname a1 == aname a2) clipped] {-

@@ -63,7 +63,7 @@ isAccountNamePrefixOf = isPrefixOf . (++ [acctsepchar])  isSubAccountNameOf :: AccountName -> AccountName -> Bool-s `isSubAccountNameOf` p = +s `isSubAccountNameOf` p =     (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1))  -- | From a list of account names, select those which are direct@@ -73,7 +73,7 @@  -- | Convert a list of account names to a tree. accountNameTreeFrom :: [AccountName] -> Tree AccountName-accountNameTreeFrom accts = +accountNameTreeFrom accts =     Node "root" (accounttreesfrom (topAccountNames accts))         where           accounttreesfrom :: [AccountName] -> [Tree AccountName]@@ -85,7 +85,7 @@  -- | Elide an account name to fit in the specified width. -- From the ledger 2.6 news:--- +-- -- @ --   What Ledger now does is that if an account name is too long, it will --   start abbreviating the first parts of the account name down to two@@ -99,7 +99,7 @@ --     ..:Af:Lu:Sn:Ca:Ch:Cash  ; Abbreviated and elided! -- @ elideAccountName :: Int -> AccountName -> AccountName-elideAccountName width s = +elideAccountName width s =     elideLeft width $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s       where         elideparts :: Int -> [String] -> [String] -> [String]@@ -108,8 +108,16 @@           | length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss)           | otherwise = done++ss +-- | Keep only the first n components of an account name, where n+-- is a positive integer. If n is 0, returns the empty string. clipAccountName :: Int -> AccountName -> AccountName clipAccountName n = accountNameFromComponents . take n . accountNameComponents++-- | Keep only the first n components of an account name, where n+-- is a positive integer. If n is 0, returns "...".+clipOrEllipsifyAccountName :: Int -> AccountName -> AccountName+clipOrEllipsifyAccountName 0 = const "..."+clipOrEllipsifyAccountName n = accountNameFromComponents . take n . accountNameComponents  -- | Convert an account name to a regular expression matching it and its subaccounts. accountNameToAccountRegex :: String -> String

@@ -1,16 +1,16 @@-{-# LANGUAGE StandaloneDeriving, RecordWildCards  #-}+{-# LANGUAGE CPP, StandaloneDeriving, RecordWildCards #-} {-| A simple 'Amount' is some quantity of money, shares, or anything else. It has a (possibly null) 'Commodity' and a numeric quantity:  @-  $1 +  $1   £-50-  EUR 3.44 +  EUR 3.44   GOOG 500   1.5h   90 apples-  0 +  0 @  It may also have an assigned 'Price', representing this amount's per-unit@@ -57,10 +57,10 @@   -- ** arithmetic   costOfAmount,   divideAmount,-  sumAmounts,   -- ** rendering   amountstyle,   showAmount,+  showAmountWithZeroCommodity,   showAmountDebug,   showAmountWithoutPrice,   maxprecision,@@ -68,14 +68,15 @@   setAmountPrecision,   withPrecision,   canonicaliseAmount,-  canonicalStyles,   -- * MixedAmount   nullmixedamt,   missingmixedamt,   mixed,   amounts,-  normaliseMixedAmountPreservingFirstPrice,-  normaliseMixedAmountPreservingPrices,+  filterMixedAmount,+  filterMixedAmountByCommodity,+  normaliseMixedAmountSquashPricesForDisplay,+  normaliseMixedAmount,   -- ** arithmetic   costOfMixedAmount,   divideMixedAmount,@@ -87,6 +88,8 @@   showMixedAmount,   showMixedAmountDebug,   showMixedAmountWithoutPrice,+  showMixedAmountOneLineWithoutPrice,+  showMixedAmountWithZeroCommodity,   showMixedAmountWithPrecision,   setMixedAmountPrecision,   canonicaliseMixedAmount,@@ -96,9 +99,13 @@ ) where  import Data.Char (isDigit)+#ifndef DOUBLE+import Data.Decimal+#endif+import Data.Function (on) import Data.List import Data.Map (findWithDefault)-import Data.Ord (comparing)+import Data.Maybe import Test.HUnit import Text.Printf import qualified Data.Map as M@@ -110,7 +117,7 @@  deriving instance Show HistoricalPrice -amountstyle = AmountStyle L False 0 '.' ',' []+amountstyle = AmountStyle L False 0 (Just '.') Nothing  ------------------------------------------------------------------------------- -- Amount@@ -138,26 +145,35 @@ amount = Amount{acommodity="", aquantity=0, aprice=NoPrice, astyle=amountstyle} nullamt = amount +-- | A temporary value for parsed transactions which had no amount specified.+missingamt :: Amount+missingamt = amount{acommodity="AUTO"}+ -- handy amount constructors for tests+#ifdef DOUBLE+roundTo = flip const+#endif num n = amount{acommodity="",  aquantity=n}-usd n = amount{acommodity="$", aquantity=n, astyle=amountstyle{asprecision=2}}-eur n = amount{acommodity="€", aquantity=n, astyle=amountstyle{asprecision=2}}-gbp n = amount{acommodity="£", aquantity=n, astyle=amountstyle{asprecision=2}}-hrs n = amount{acommodity="h", aquantity=n, astyle=amountstyle{asprecision=1, ascommodityside=R}}+usd n = amount{acommodity="$", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=2}}+eur n = amount{acommodity="€", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=2}}+gbp n = amount{acommodity="£", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=2}}+hrs n = amount{acommodity="h", aquantity=roundTo 1 n, astyle=amountstyle{asprecision=1, ascommodityside=R}}+amt `at` priceamt = amt{aprice=UnitPrice priceamt}+amt @@ priceamt = amt{aprice=TotalPrice priceamt} --- | Apply a binary arithmetic operator to two amounts in the same--- commodity.  Warning, as a kludge to support folds (eg sum) we assign--- the second's commodity to the first so the same commodity requirement--- is not checked. The highest precision of either amount is preserved in--- the result. Any prices are currently ignored and discarded. The display--- style is that of the first amount, with precision set to the highest of--- either amount.-similarAmountsOp :: (Double -> Double -> Double) -> Amount -> Amount -> Amount-similarAmountsOp op Amount{acommodity=_,  aquantity=aq, astyle=AmountStyle{asprecision=ap}}-                    Amount{acommodity=bc, aquantity=bq, astyle=bs@AmountStyle{asprecision=bp}} =-   -- trace ("a:"++showAmount a) $ trace ("b:"++showAmount b++"\n") $ tracewith (("=:"++).showAmount)-   amount{acommodity=bc, aquantity=aq `op` bq, astyle=bs{asprecision=max ap bp}}-  --  ac==bc    = amount{acommodity=ac, aquantity=aq `op` bq, astyle=as{asprecision=max ap bp}}+-- | Apply a binary arithmetic operator to two amounts, which should+-- be in the same commodity if non-zero (warning, this is not checked).+-- A zero result keeps the commodity of the second amount.+-- The result's display style is that of the second amount, with+-- precision set to the highest of either amount.+-- Prices are ignored and discarded.+-- Remember: the caller is responsible for ensuring both amounts have the same commodity.+similarAmountsOp :: (Quantity -> Quantity -> Quantity) -> Amount -> Amount -> Amount+similarAmountsOp op Amount{acommodity=_,  aquantity=q1, astyle=AmountStyle{asprecision=p1}}+                    Amount{acommodity=c2, aquantity=q2, astyle=s2@AmountStyle{asprecision=p2}} =+   -- trace ("a1:"++showAmountDebug a1) $ trace ("a2:"++showAmountDebug a2) $ traceWith (("= :"++).showAmountDebug)+   amount{acommodity=c2, aquantity=q1 `op` q2, astyle=s2{asprecision=max p1 p2}}+  --  c1==c2 || q1==0 || q2==0 =   --  otherwise = error "tried to do simple arithmetic with amounts in different commodities"  -- | Convert an amount to the specified commodity, ignoring and discarding@@ -165,30 +181,6 @@ amountWithCommodity :: Commodity -> Amount -> Amount amountWithCommodity c a = a{acommodity=c, aprice=NoPrice} --- | A more complete amount adding operation.-sumAmounts :: [Amount] -> MixedAmount-sumAmounts = normaliseMixedAmountPreservingPrices . Mixed---- | Set an amount's unit price.-at :: Amount -> Amount -> Amount-amt `at` priceamt = amt{aprice=UnitPrice priceamt}---- | Set an amount's total price.-(@@) :: Amount -> Amount -> Amount-amt @@ priceamt = amt{aprice=TotalPrice priceamt}--tests_sumAmounts = [-  "sumAmounts" ~: do-    -- when adding, we don't convert to the price commodity - just-    -- combine what amounts we can.-    -- amounts with same unit price-    sumAmounts [usd 1 `at` eur 1, usd 1 `at` eur 1] `is` Mixed [usd 2 `at` eur 1]-    -- amounts with different unit prices-    -- amounts with total prices-    sumAmounts  [usd 1 @@ eur 1, usd 1 @@ eur 1] `is` Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]-    -- amounts with no, unit, and/or total prices- ]- -- | Convert an amount to the commodity of its assigned price, if any.  Notes: -- -- - price amounts must be MixedAmounts with exactly one component Amount (or there will be a runtime error)@@ -202,7 +194,7 @@       TotalPrice p@Amount{aquantity=pq} -> p{aquantity=pq * signum q}  -- | Divide an amount's quantity by a constant.-divideAmount :: Amount -> Double -> Amount+divideAmount :: Amount -> Quantity -> Amount divideAmount a@Amount{aquantity=q} d = a{aquantity=q/d}  -- | Is this amount negative ? The price is ignored.@@ -219,9 +211,14 @@ -- | Is this amount "really" zero, regardless of the display precision ? -- Since we are using floating point, for now just test to some high precision. isReallyZeroAmount :: Amount -> Bool-isReallyZeroAmount a --  a==missingamt = False-                     | otherwise     = (null . filter (`elem` digits) . printf ("%."++show zeroprecision++"f") . aquantity) a-    where zeroprecision = 8+isReallyZeroAmount Amount{aquantity=q} = iszero q+  where+   iszero =+#ifdef DOUBLE+    null . filter (`elem` digits) . printf ("%."++show zeroprecision++"f") where zeroprecision = 8+#else+    (==0)+#endif  -- | Get the string representation of an amount, based on its commodity's -- display settings except using the specified precision.@@ -260,54 +257,73 @@ showPriceDebug (UnitPrice pa)  = " @ "  ++ showAmountDebug pa showPriceDebug (TotalPrice pa) = " @@ " ++ showAmountDebug pa --- | Get the string representation of an amount, based on its commodity's--- display settings. String representations equivalent to zero are--- converted to just \"0\".+-- | Get the string representation of an amount, based on its+-- commodity's display settings. String representations equivalent to+-- zero are converted to just \"0\". The special "missing" amount is+-- displayed as the empty string. showAmount :: Amount -> String-showAmount Amount{acommodity="AUTO"} = ""-showAmount a@(Amount{acommodity=c, aprice=p, astyle=AmountStyle{..}}) =+showAmount = showAmountHelper False++showAmountHelper :: Bool -> Amount -> String+showAmountHelper _ Amount{acommodity="AUTO"} = ""+showAmountHelper showzerocommodity a@(Amount{acommodity=c, aprice=p, astyle=AmountStyle{..}}) =     case ascommodityside of       L -> printf "%s%s%s%s" c' space quantity' price       R -> printf "%s%s%s%s" quantity' space c' price     where       quantity = showamountquantity a       displayingzero = null $ filter (`elem` digits) $ quantity-      (quantity',c') | displayingzero = ("0","")-                     | otherwise      = (quantity, quoteCommoditySymbolIfNeeded c)+      (quantity',c') | displayingzero && not showzerocommodity = ("0","")+                     | otherwise = (quantity, quoteCommoditySymbolIfNeeded c)       space = if (not (null c') && ascommodityspaced) then " " else "" :: String       price = showPrice p +-- | Like showAmount, but show a zero amount's commodity if it has one.+showAmountWithZeroCommodity :: Amount -> String+showAmountWithZeroCommodity = showAmountHelper True+ -- | Get the string representation of the number part of of an amount, -- using the display settings from its commodity. showamountquantity :: Amount -> String-showamountquantity Amount{aquantity=q, astyle=AmountStyle{asprecision=p, asdecimalpoint=d, asseparator=s, asseparatorpositions=spos}} =-    punctuatenumber d s spos $ qstr+showamountquantity Amount{aquantity=q, astyle=AmountStyle{asprecision=p, asdecimalpoint=mdec, asdigitgroups=mgrps}} =+    punctuatenumber (fromMaybe '.' mdec) mgrps $ qstr     where-    -- isint n = fromIntegral (round n) == n-    qstr -- p == maxprecision && isint q = printf "%d" (round q::Integer)-         | p == maxprecisionwithpoint    = printf "%f" q-         | p == maxprecision             = chopdotzero $ printf "%f" q-         | otherwise                    = printf ("%."++show p++"f") q+      -- isint n = fromIntegral (round n) == n+      qstr -- p == maxprecision && isint q = printf "%d" (round q::Integer)+#ifdef DOUBLE+        | p == maxprecisionwithpoint = printf "%f" q+        | p == maxprecision          = chopdotzero $ printf "%f" q+        | otherwise                  = printf ("%."++show p++"f") q+#else+        | p == maxprecisionwithpoint = show q+        | p == maxprecision          = chopdotzero $ show q+        | otherwise                  = show $ roundTo (fromIntegral p) q+#endif  -- | Replace a number string's decimal point with the specified character, -- and add the specified digit group separators. The last digit group will -- be repeated as needed.-punctuatenumber :: Char -> Char -> [Int] -> String -> String-punctuatenumber dec sep grps str = sign ++ reverse (addseps sep (extend grps) (reverse int)) ++ frac''+punctuatenumber :: Char -> Maybe DigitGroupStyle -> String -> String+punctuatenumber dec mgrps s = sign ++ reverse (applyDigitGroupStyle mgrps (reverse int)) ++ frac''     where-      (sign,num) = break isDigit str+      (sign,num) = break isDigit s       (int,frac) = break (=='.') num       frac' = dropWhile (=='.') frac       frac'' | null frac' = ""              | otherwise  = dec:frac'-      extend [] = []-      extend gs = init gs ++ repeat (last gs)-      addseps _ [] str = str-      addseps sep (g:gs) str-          | length str <= g = str-          | otherwise = let (s,rest) = splitAt g str-                        in s ++ [sep] ++ addseps sep gs rest +applyDigitGroupStyle :: Maybe DigitGroupStyle -> String -> String+applyDigitGroupStyle Nothing s = s+applyDigitGroupStyle (Just (DigitGroups c gs)) s = addseps (repeatLast gs) s+  where+    addseps [] s = s+    addseps (g:gs) s+      | length s <= g = s+      | otherwise     = let (part,rest) = splitAt g s+                        in part ++ [c] ++ addseps gs rest+    repeatLast [] = []+    repeatLast gs = init gs ++ repeat (last gs)+ chopdotzero str = reverse $ case reverse str of                               '0':'.':s -> s                               s         -> s@@ -339,108 +355,144 @@ instance Num MixedAmount where     fromInteger i = Mixed [fromInteger i]     negate (Mixed as) = Mixed $ map negate as-    (+) (Mixed as) (Mixed bs) = normaliseMixedAmountPreservingPrices $ 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"+    (+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs+    (*)    = error' "error, mixed amounts do not support multiplication"+    abs    = error' "error, mixed amounts do not support abs"+    signum = error' "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 :: Amount-missingamt = amount{acommodity="AUTO"}- missingmixedamt :: MixedAmount missingmixedamt = Mixed [missingamt] -mixed :: Amount -> MixedAmount-mixed a = Mixed [a]-  --- | Simplify a mixed amount's component amounts: we can combine amounts--- with the same commodity and unit price. Also remove any zero or missing--- amounts and replace an empty amount list with a single zero amount.-normaliseMixedAmountPreservingPrices :: MixedAmount -> MixedAmount-normaliseMixedAmountPreservingPrices (Mixed as) = Mixed as''-    where-      as'' = if null nonzeros then [nullamt] else nonzeros-      (_,nonzeros) = partition isReallyZeroAmount as'-      as' = map sumAmountsUsingFirstPrice $ group $ sort $ filter (/= missingamt) as-      sort = sortBy (\a1 a2 -> compare (acommodity a1, aprice a1) (acommodity a2, aprice a2))-      group = groupBy (\a1 a2 -> acommodity a1 == acommodity a2 && sameunitprice a1 a2)-        where-          sameunitprice a1 a2 =-            case (aprice a1, aprice a2) of-              (NoPrice, NoPrice) -> True-              (UnitPrice p1, UnitPrice p2) -> p1 == p2-              _ -> False+-- | Convert amounts in various commodities into a normalised MixedAmount.+mixed :: [Amount] -> MixedAmount+mixed = normaliseMixedAmount . Mixed -tests_normaliseMixedAmountPreservingPrices = [-  "normaliseMixedAmountPreservingPrices" ~: do-   assertEqual "discard missing amount" (Mixed [nullamt]) (normaliseMixedAmountPreservingPrices $ Mixed [usd 0, missingamt])-   assertEqual "combine unpriced same-commodity amounts" (Mixed [usd 2]) (normaliseMixedAmountPreservingPrices $ Mixed [usd 0, usd 2])-   assertEqual "don't combine total-priced amounts"-     (Mixed-      [usd 1 @@ eur 1-      ,usd (-2) @@ eur 1-      ])-     (normaliseMixedAmountPreservingPrices $ Mixed-      [usd 1 @@ eur 1-      ,usd (-2) @@ eur 1-      ])+-- | Simplify a mixed amount's component amounts:+--+-- * amounts in the same commodity are combined unless they have different prices or total prices+--+-- * multiple zero amounts are replaced by just one. If they had the same commodity, it is preserved.+--+-- * an empty amount list is replaced with a single commodityless zero+--+-- * the special "missing" mixed amount remains unchanged+--+normaliseMixedAmount :: MixedAmount -> MixedAmount+normaliseMixedAmount = normaliseHelper False +normaliseHelper :: Bool -> MixedAmount -> MixedAmount+normaliseHelper squashprices (Mixed as)+  | missingamt `elem` as = missingmixedamt -- missingamt should always be alone, but detect it even if not+  | null nonzeros        = Mixed [newzero]+  | otherwise            = Mixed nonzeros+  where+    newzero = case filter (/= "") (map acommodity zeros) of+               [c] -> nullamt{acommodity=c}+               _   -> nullamt+    (zeros, nonzeros) = partition isReallyZeroAmount $+                        map sumSimilarAmountsUsingFirstPrice $+                        groupBy groupfn $+                        sortBy sortfn $+                        as+    sortfn  | squashprices = compare `on` acommodity+            | otherwise    = compare `on` \a -> (acommodity a, aprice a)+    groupfn | squashprices = (==) `on` acommodity+            | otherwise    = \a1 a2 -> acommodity a1 == acommodity a2 && combinableprices a1 a2++    combinableprices Amount{aprice=NoPrice} Amount{aprice=NoPrice} = True+    combinableprices Amount{aprice=UnitPrice p1} Amount{aprice=UnitPrice p2} = p1 == p2+    combinableprices _ _ = False++tests_normaliseMixedAmount = [+  "normaliseMixedAmount" ~: do+   -- assertEqual "missing amount is discarded" (Mixed [nullamt]) (normaliseMixedAmount $ Mixed [usd 0, missingamt])+   assertEqual "any missing amount means a missing mixed amount" missingmixedamt (normaliseMixedAmount $ Mixed [usd 0, missingamt])+   assertEqual "unpriced same-commodity amounts are combined" (Mixed [usd 2]) (normaliseMixedAmount $ Mixed [usd 0, usd 2])+   -- amounts with same unit price are combined+   normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) `is` Mixed [usd 2 `at` eur 1]+   -- amounts with different unit prices are not combined+   normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) `is` Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]+   -- amounts with total prices are not combined+   normaliseMixedAmount (Mixed  [usd 1 @@ eur 1, usd 1 @@ eur 1]) `is` Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]  ] --- | Simplify a mixed amount's component amounts: combine amounts with--- the same commodity, using the first amount's price for subsequent--- amounts in each commodity (ie, this function alters the amount and--- is best used as a rendering helper.). Also remove any zero amounts--- and replace an empty amount list with a single zero amount.-normaliseMixedAmountPreservingFirstPrice :: MixedAmount -> MixedAmount-normaliseMixedAmountPreservingFirstPrice (Mixed as) = Mixed as''-    where -      as'' = if null nonzeros then [nullamt] else nonzeros-      (_,nonzeros) = partition (\a -> isReallyZeroAmount a && a /= missingamt) as'-      as' = map sumAmountsUsingFirstPrice $ group $ sort as-      sort = sortBy (\a1 a2 -> compare (acommodity a1) (acommodity a2))-      group = groupBy (\a1 a2 -> acommodity a1 == acommodity a2)+-- | Like normaliseMixedAmount, but combine each commodity's amounts+-- into just one by throwing away all prices except the first. This is+-- only used as a rendering helper, and could show a misleading price.+normaliseMixedAmountSquashPricesForDisplay :: MixedAmount -> MixedAmount+normaliseMixedAmountSquashPricesForDisplay = normaliseHelper True --- discardPrice :: Amount -> Amount--- discardPrice a = a{price=Nothing}+tests_normaliseMixedAmountSquashPricesForDisplay = [+  "normaliseMixedAmountSquashPricesForDisplay" ~: do+    normaliseMixedAmountSquashPricesForDisplay (Mixed []) `is` Mixed [nullamt]+    assertBool "" $ isZeroMixedAmount $ normaliseMixedAmountSquashPricesForDisplay+      (Mixed [usd 10+             ,usd 10 @@ eur 7+             ,usd (-10)+             ,usd (-10) @@ eur 7+             ])+ ] --- discardPrices :: MixedAmount -> MixedAmount--- discardPrices (Mixed as) = Mixed $ map discardPrice as+-- | Sum same-commodity amounts in a lossy way, applying the first+-- price to the result and discarding any other prices. Only used as a+-- rendering helper.+sumSimilarAmountsUsingFirstPrice :: [Amount] -> Amount+sumSimilarAmountsUsingFirstPrice [] = nullamt+sumSimilarAmountsUsingFirstPrice as = (sum as){aprice=aprice $ head as} -sumAmountsUsingFirstPrice [] = nullamt-sumAmountsUsingFirstPrice as = (sum as){aprice=aprice $ head as}+-- | Sum same-commodity amounts. If there were different prices, set+-- the price to a special marker indicating "various". Only used as a+-- rendering helper.+-- sumSimilarAmountsNotingPriceDifference :: [Amount] -> Amount+-- sumSimilarAmountsNotingPriceDifference [] = nullamt+-- sumSimilarAmountsNotingPriceDifference as = undefined  -- | Get a mixed amount's component amounts. amounts :: MixedAmount -> [Amount] amounts (Mixed as) = as +-- | Filter a mixed amount's component amounts by a predicate.+filterMixedAmount :: (Amount -> Bool) -> MixedAmount -> MixedAmount+filterMixedAmount p (Mixed as) = Mixed $ filter p as++-- | Return an unnormalised MixedAmount containing exactly one Amount+-- with the specified commodity and the quantity of that commodity+-- found in the original. NB if Amount's quantity is zero it will be+-- discarded next time the MixedAmount gets normalised.+filterMixedAmountByCommodity :: Commodity -> MixedAmount -> MixedAmount+filterMixedAmountByCommodity c (Mixed as) = Mixed as'+  where+    as' = case filter ((==c) . acommodity) as of+            []   -> [nullamt{acommodity=c}]+            as'' -> [sum 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 :: MixedAmount -> Quantity -> 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 $ normaliseMixedAmountPreservingFirstPrice m+    where as = amounts $ normaliseMixedAmountSquashPricesForDisplay m  -- | Does this mixed amount appear to be zero when displayed with its given precision ? isZeroMixedAmount :: MixedAmount -> Bool-isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmountPreservingFirstPrice+isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmountSquashPricesForDisplay  -- | Is this mixed amount "really" zero ? See isReallyZeroAmount. isReallyZeroMixedAmount :: MixedAmount -> Bool-isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmountPreservingFirstPrice+isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmountSquashPricesForDisplay  -- | Is this mixed amount "really" zero, after converting to cost -- commodities where possible ?@@ -452,15 +504,27 @@ -- -- 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' = normaliseMixedAmountPreservingFirstPrice a---           b' = normaliseMixedAmountPreservingFirstPrice b+--     where a' = normaliseMixedAmountSquashPricesForDisplay a+--           b' = normaliseMixedAmountSquashPricesForDisplay b --- | Get the string representation of a mixed amount, showing each of--- its component amounts. NB a mixed amount can have an empty amounts--- list in which case it shows as \"\".+-- | Get the string representation of a mixed amount, after+-- normalising it to one amount per commodity. Assumes amounts have+-- no or similar prices, otherwise this can show misleading prices. showMixedAmount :: MixedAmount -> String-showMixedAmount m = vConcatRightAligned $ map showAmount $ amounts $  normaliseMixedAmountPreservingFirstPrice m+showMixedAmount = showMixedAmountHelper False +-- | Like showMixedAmount, but zero amounts are shown with their+-- commodity if they have one.+showMixedAmountWithZeroCommodity :: MixedAmount -> String+showMixedAmountWithZeroCommodity = showMixedAmountHelper True++showMixedAmountHelper :: Bool -> MixedAmount -> String+showMixedAmountHelper showzerocommodity m =+  vConcatRightAligned $ map showw $ amounts $ normaliseMixedAmountSquashPricesForDisplay m+  where+    showw | showzerocommodity = showAmountWithZeroCommodity+          | otherwise         = showAmount+ -- | Compact labelled trace of a mixed amount, for debugging. ltraceamount :: String -> MixedAmount -> MixedAmount ltraceamount s = traceWith (((s ++ ": ") ++).showMixedAmount)@@ -474,51 +538,42 @@ -- commoditys' display precision settings. showMixedAmountWithPrecision :: Int -> MixedAmount -> String showMixedAmountWithPrecision p m =-    vConcatRightAligned $ map (showAmountWithPrecision p) $ amounts $ normaliseMixedAmountPreservingFirstPrice m+    vConcatRightAligned $ map (showAmountWithPrecision p) $ amounts $ normaliseMixedAmountSquashPricesForDisplay m  -- | Get an unambiguous string representation of a mixed amount for debugging. showMixedAmountDebug :: MixedAmount -> String showMixedAmountDebug m | m == missingmixedamt = "(missing)"                        | otherwise       = printf "Mixed [%s]" as-    where as = intercalate "\n       " $ map showAmountDebug $ amounts m -- normaliseMixedAmountPreservingFirstPrice m+    where as = intercalate "\n       " $ map showAmountDebug $ amounts m  -- | Get the string representation of a mixed amount, but without -- any \@ prices. showMixedAmountWithoutPrice :: MixedAmount -> String showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth as     where-      (Mixed as) = normaliseMixedAmountPreservingFirstPrice $ stripPrices m+      (Mixed as) = normaliseMixedAmountSquashPricesForDisplay $ stripPrices m       stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=NoPrice}       width = maximum $ map (length . showAmount) as       showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice +-- | Get the one-line string representation of a mixed amount, but without+-- any \@ prices.+showMixedAmountOneLineWithoutPrice :: MixedAmount -> String+showMixedAmountOneLineWithoutPrice m = concat $ intersperse ", " $ map showAmountWithoutPrice as+    where+      (Mixed as) = normaliseMixedAmountSquashPricesForDisplay $ stripPrices m+      stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=NoPrice}+ -- | Canonicalise a mixed amount's display styles using the provided commodity style map. canonicaliseMixedAmount :: M.Map Commodity AmountStyle -> MixedAmount -> MixedAmount canonicaliseMixedAmount styles (Mixed as) = Mixed $ map (canonicaliseAmount styles) as --- | Given a list of amounts in parse order, build a map from commodities--- to canonical display styles for amounts in that commodity.-canonicalStyles :: [Amount] -> M.Map Commodity AmountStyle-canonicalStyles amts = M.fromList commstyles-  where-    samecomm = \a1 a2 -> acommodity a1 == acommodity a2-    commamts = [(acommodity $ head as, as) | as <- groupBy samecomm $ sortBy (comparing acommodity) amts]-    commstyles = [(c, s)-                 | (c,as) <- commamts-                 , let styles = map astyle as-                 , let maxprec = maximum $ map asprecision styles-                 , let s = (head styles){asprecision=maxprec}-                 ]---- lookupStyle :: M.Map Commodity AmountStyle -> Commodity -> AmountStyle--- lookupStyle - ------------------------------------------------------------------------------- -- misc  tests_Hledger_Data_Amount = TestList $-     tests_normaliseMixedAmountPreservingPrices-  ++ tests_sumAmounts+     tests_normaliseMixedAmount+  ++ tests_normaliseMixedAmountSquashPricesForDisplay   ++ [    -- Amount@@ -561,25 +616,16 @@    -- MixedAmount -  ,"normaliseMixedAmountPreservingFirstPrice" ~: do-    normaliseMixedAmountPreservingFirstPrice (Mixed []) `is` Mixed [nullamt]-    assertBool "" $ isZeroMixedAmount $ normaliseMixedAmountPreservingFirstPrice-      (Mixed [usd 10-             ,usd 10 @@ eur 7-             ,usd (-10)-             ,usd (-10) @@ eur 7-             ])--  ,"adding mixed amounts" ~: do-    (sum $ map (Mixed . (\a -> [a]))+  ,"adding mixed amounts, preserving minimum precision and a single commodity on zero" ~: do+    (sum $ map (Mixed . (:[]))              [usd 1.25              ,usd (-1) `withPrecision` 0              ,usd (-0.25)              ])-      `is` Mixed [amount{aquantity=0}]-  +      `is` Mixed [usd 0 `withPrecision` 0]+   ,"adding mixed amounts with total prices" ~: do-    (sum $ map (Mixed . (\a -> [a]))+    (sum $ map (Mixed . (:[]))      [usd 1 @@ eur 1      ,usd (-2) @@ eur 1      ])

@@ -43,8 +43,8 @@  -- | Look up one of the sample commodities' symbol by name. comm :: String -> Commodity-comm name = snd $ fromMaybe -              (error' "commodity lookup failed") +comm name = snd $ fromMaybe+              (error' "commodity lookup failed")               (find (\n -> fst n == name) commoditysymbols)  -- | Find the conversion rate between two commodities. Currently returns 1.

@@ -1,4 +1,5 @@ {-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts #-} {-|  Date parsing and utilities for hledger.@@ -38,6 +39,8 @@   nulldatespan,   tests_Hledger_Data_Dates,   failIfInvalidYear,+  failIfInvalidMonth,+  failIfInvalidDay,   datesepchar,   datesepchars,   spanStart,@@ -60,18 +63,20 @@ ) where +import Control.Applicative ((<*)) 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.Calendar.WeekDate import Data.Time.Clock import Data.Time.LocalTime import Safe (headMay, lastMay, readMay) import System.Locale (defaultTimeLocale) import Test.HUnit-import Text.ParserCombinators.Parsec+import Text.Parsec import Text.Printf  import Hledger.Data.Types@@ -85,7 +90,58 @@ showDate :: Day -> String showDate = formatTime defaultTimeLocale "%0C%y/%m/%d" -showDateSpan (DateSpan from to) =+-- XXX review for more boundary crossing issues+-- | Render a datespan as a display string, abbreviating into a+-- compact form if possible.+showDateSpan ds@(DateSpan (Just from) (Just to)) =+  case (toGregorian from, toGregorian to) of+    -- special cases we can abbreviate:+    -- a year, YYYY+    ((fy,1,1), (ty,1,1))   | fy+1==ty           -> formatTime defaultTimeLocale "%0C%y" from+    -- a half, YYYYhN+    ((fy,1,1), (ty,7,1))   | fy==ty             -> formatTime defaultTimeLocale "%0C%yh1" from+    ((fy,7,1), (ty,1,1))   | fy+1==ty           -> formatTime defaultTimeLocale "%0C%yh2" from+    -- a quarter, YYYYqN+    ((fy,1,1), (ty,4,1))   | fy==ty             -> formatTime defaultTimeLocale "%0C%yq1" from+    ((fy,4,1), (ty,7,1))   | fy==ty             -> formatTime defaultTimeLocale "%0C%yq2" from+    ((fy,7,1), (ty,10,1))  | fy==ty             -> formatTime defaultTimeLocale "%0C%yq3" from+    ((fy,10,1), (ty,1,1))  | fy+1==ty           -> formatTime defaultTimeLocale "%0C%yq4" from+    -- a month, YYYY/MM+    ((fy,fm,1), (ty,tm,1)) | fy==ty && fm+1==tm -> formatTime defaultTimeLocale "%0C%y/%m" from+    ((fy,12,1), (ty,1,1))  | fy+1==ty           -> formatTime defaultTimeLocale "%0C%y/%m" from+    -- a week (two successive mondays),+    -- YYYYwN ("week N of year YYYY")+    -- _ | let ((fy,fw,fd), (ty,tw,td)) = (toWeekDate from, toWeekDate to) in fy==ty && fw+1==tw && fd==1 && td==1+    --                                             -> formatTime defaultTimeLocale "%0f%gw%V" from+    -- YYYY/MM/DDwN ("week N, starting on YYYY/MM/DD")+    _ | let ((fy,fw,fd), (ty,tw,td)) = (toWeekDate from, toWeekDate to) in fy==ty && fw+1==tw && fd==1 && td==1+                                                -> formatTime defaultTimeLocale "%0C%y/%m/%dw%V" from+    -- a day, YYYY/MM/DDd (d suffix is to distinguish from a regular date in register)+    ((fy,fm,fd), (ty,tm,td)) | fy==ty && fm==tm && fd+1==td -> formatTime defaultTimeLocale "%0C%y/%m/%dd" from+    -- crossing a year boundary+    ((fy,fm,fd), (ty,tm,td)) | fy+1==ty && fm==12 && tm==1 && fd==31 && td==1 -> formatTime defaultTimeLocale "%0C%y/%m/%dd" from+    -- crossing a month boundary XXX wrongly shows LEAPYEAR/2/28-LEAPYEAR/3/1 as LEAPYEAR/2/28+    ((fy,fm,fd), (ty,tm,td)) | fy==ty && fm+1==tm && fd `elem` fromMaybe [] (lookup fm lastdayofmonth) && td==1 -> formatTime defaultTimeLocale "%0C%y/%m/%dd" from+    -- otherwise, YYYY/MM/DD-YYYY/MM/DD+    _                                           -> showDateSpan' ds+  where lastdayofmonth = [(1,[31])+                         ,(2,[28,29])+                         ,(3,[31])+                         ,(4,[30])+                         ,(5,[30])+                         ,(6,[31])+                         ,(7,[31])+                         ,(8,[31])+                         ,(9,[30])+                         ,(10,[31])+                         ,(11,[30])+                         ,(12,[31])+                         ]++showDateSpan ds = showDateSpan' ds++-- | Render a datespan as a display string.+showDateSpan' (DateSpan from to) =   concat     [maybe "" showDate from     ,"-"@@ -119,7 +175,7 @@ spanEnd :: DateSpan -> Maybe Day spanEnd (DateSpan _ d) = d --- might be useful later: http://en.wikipedia.org/wiki/Allen%27s_interval_algebra +-- might be useful later: http://en.wikipedia.org/wiki/Allen%27s_interval_algebra  -- | Get overall span enclosing multiple sequentially ordered spans. spansSpan :: [DateSpan] -> DateSpan@@ -170,7 +226,7 @@ spanContainsDate (DateSpan Nothing (Just e))  d = d < e spanContainsDate (DateSpan (Just b) Nothing)  d = d >= b spanContainsDate (DateSpan (Just b) (Just e)) d = d >= b && d < e-    + -- | Calculate the intersection of a number of datespans. spansIntersect [] = nulldatespan spansIntersect [d] = d@@ -210,7 +266,7 @@ -- | Parse a period expression to an Interval and overall DateSpan using -- the provided reference date, or return a parse error. parsePeriodExpr :: Day -> String -> Either ParseError (Interval, DateSpan)-parsePeriodExpr refdate = parsewith (periodexpr refdate)+parsePeriodExpr refdate = parsewith (periodexpr refdate <* eof)  maybePeriod :: Day -> String -> Maybe (Interval,DateSpan) maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate@@ -221,7 +277,7 @@ -- dateSpanAsText (DateSpan Nothing (Just e))  = printf "to %s" (show e) -- dateSpanAsText (DateSpan (Just b) Nothing)  = printf "from %s" (show b) -- dateSpanAsText (DateSpan (Just b) (Just e)) = printf "%s to %s" (show b) (show e)-    + -- | Convert a single smart date string to a date span using the provided -- reference date, or raise an error. -- spanFromSmartDateString :: Day -> String -> DateSpan@@ -366,9 +422,9 @@  -- | Parse a couple of date string formats to a time type. parsedateM :: String -> Maybe Day-parsedateM s = firstJust [ +parsedateM s = firstJust [      parseTime defaultTimeLocale "%Y/%m/%d" s,-     parseTime defaultTimeLocale "%Y-%m-%d" s +     parseTime defaultTimeLocale "%Y-%m-%d" s      ]  -- -- | Parse a date-time string to a time type, or raise an error.@@ -386,7 +442,7 @@ parsetimewith :: ParseTime t => String -> String -> t -> t parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s -{-| +{-| Parse a date in any of the formats allowed in ledger's period expressions, and maybe some others: @@ -402,14 +458,14 @@ Returns a SmartDate, to be converted to a full date later (see fixSmartDate). Assumes any text in the parse stream has been lowercased. -}-smartdate :: GenParser Char st SmartDate+smartdate :: Stream [Char] m Char => ParsecT [Char] st m SmartDate smartdate = do   -- XXX maybe obscures date errors ? see ledgerdate   (y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing]   return (y,m,d)  -- | Like smartdate, but there must be nothing other than whitespace after the date.-smartdateonly :: GenParser Char st SmartDate+smartdateonly :: Stream [Char] m Char => ParsecT [Char] st m SmartDate smartdateonly = do   d <- smartdate   many spacenonewline@@ -417,6 +473,7 @@   return d  datesepchars = "/-."+datesepchar :: Stream [Char] m Char => ParsecT [Char] st m Char datesepchar = oneOf datesepchars  validYear, validMonth, validDay :: String -> Bool@@ -429,7 +486,7 @@ failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s failIfInvalidDay s   = unless (validDay s)   $ fail $ "bad day number: " ++ s -yyyymmdd :: GenParser Char st SmartDate+yyyymmdd :: Stream [Char] m Char => ParsecT [Char] st m SmartDate yyyymmdd = do   y <- count 4 digit   m <- count 2 digit@@ -438,19 +495,19 @@   failIfInvalidDay d   return (y,m,d) -ymd :: GenParser Char st SmartDate+ymd :: Stream [Char] m Char => ParsecT [Char] st m SmartDate ymd = do   y <- many1 digit   failIfInvalidYear y-  datesepchar+  sep <- datesepchar   m <- many1 digit   failIfInvalidMonth m-  datesepchar+  char sep   d <- many1 digit   failIfInvalidDay d   return $ (y,m,d) -ym :: GenParser Char st SmartDate+ym :: Stream [Char] m Char => ParsecT [Char] st m SmartDate ym = do   y <- many1 digit   failIfInvalidYear y@@ -459,19 +516,19 @@   failIfInvalidMonth m   return (y,m,"") -y :: GenParser Char st SmartDate+y :: Stream [Char] m Char => ParsecT [Char] st m SmartDate y = do   y <- many1 digit   failIfInvalidYear y   return (y,"","") -d :: GenParser Char st SmartDate+d :: Stream [Char] m Char => ParsecT [Char] st m SmartDate d = do   d <- many1 digit   failIfInvalidDay d   return ("","",d) -md :: GenParser Char st SmartDate+md :: Stream [Char] m Char => ParsecT [Char] st m SmartDate md = do   m <- many1 digit   failIfInvalidMonth m@@ -489,24 +546,24 @@ monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months monIndex s   = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs -month :: GenParser Char st SmartDate+month :: Stream [Char] m Char => ParsecT [Char] st m SmartDate month = do   m <- choice $ map (try . string) months   let i = monthIndex m   return ("",show i,"") -mon :: GenParser Char st SmartDate+mon :: Stream [Char] m Char => ParsecT [Char] st m SmartDate mon = do   m <- choice $ map (try . string) monthabbrevs   let i = monIndex m   return ("",show i,"") -today,yesterday,tomorrow :: GenParser Char st SmartDate+today,yesterday,tomorrow :: Stream [Char] m Char => ParsecT [Char] st m SmartDate today     = string "today"     >> return ("","","today") yesterday = string "yesterday" >> return ("","","yesterday") tomorrow  = string "tomorrow"  >> return ("","","tomorrow") -lastthisnextthing :: GenParser Char st SmartDate+lastthisnextthing :: Stream [Char] m Char => ParsecT [Char] st m SmartDate lastthisnextthing = do   r <- choice [         string "last"@@ -523,10 +580,10 @@       ] -- XXX support these in fixSmartDate --       ++ (map string $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs)-            +   return ("",r,p) -periodexpr :: Day -> GenParser Char st (Interval, DateSpan)+periodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan) periodexpr rdate = choice $ map try [                     intervalanddateperiodexpr rdate,                     intervalperiodexpr,@@ -534,7 +591,7 @@                     (return (NoInterval,DateSpan Nothing Nothing))                    ] -intervalanddateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan)+intervalanddateperiodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan) intervalanddateperiodexpr rdate = do   many spacenonewline   i <- reportinginterval@@ -542,20 +599,20 @@   s <- periodexprdatespan rdate   return (i,s) -intervalperiodexpr :: GenParser Char st (Interval, DateSpan)+intervalperiodexpr :: Stream [Char] m Char => ParsecT [Char] st m (Interval, DateSpan) intervalperiodexpr = do   many spacenonewline   i <- reportinginterval   return (i, DateSpan Nothing Nothing) -dateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan)+dateperiodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan) dateperiodexpr rdate = do   many spacenonewline   s <- periodexprdatespan rdate   return (NoInterval, s)  -- Parse a reporting interval.-reportinginterval :: GenParser Char st Interval+reportinginterval :: Stream [Char] m Char => ParsecT [Char] st m Interval reportinginterval = choice' [                        tryinterval "day"     "daily"     Days,                        tryinterval "week"    "weekly"    Weeks,@@ -595,7 +652,7 @@       thsuffix = choice' $ map string ["st","nd","rd","th"]        -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days".-      tryinterval :: String -> String -> (Int -> Interval) -> GenParser Char st Interval+      tryinterval :: Stream [Char] m Char => String -> String -> (Int -> Interval) -> ParsecT [Char] st m Interval       tryinterval singular compact intcons =           choice' [            do string compact@@ -613,7 +670,7 @@            ]           where plural = singular ++ "s" -periodexprdatespan :: Day -> GenParser Char st DateSpan+periodexprdatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan periodexprdatespan rdate = choice $ map try [                             doubledatespan rdate,                             fromdatespan rdate,@@ -621,7 +678,7 @@                             justdatespan rdate                            ] -doubledatespan :: Day -> GenParser Char st DateSpan+doubledatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan doubledatespan rdate = do   optional (string "from" >> many spacenonewline)   b <- smartdate@@ -630,7 +687,7 @@   e <- smartdate   return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) -fromdatespan :: Day -> GenParser Char st DateSpan+fromdatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan fromdatespan rdate = do   b <- choice [     do@@ -644,13 +701,13 @@     ]   return $ DateSpan (Just $ fixSmartDate rdate b) Nothing -todatespan :: Day -> GenParser Char st DateSpan+todatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan todatespan rdate = do   choice [string "to", string "-"] >> many spacenonewline   e <- smartdate   return $ DateSpan Nothing (Just $ fixSmartDate rdate e) -justdatespan :: Day -> GenParser Char st DateSpan+justdatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan justdatespan rdate = do   optional (string "in" >> many spacenonewline)   d <- smartdate

@@ -22,7 +22,8 @@   -- * Filtering   filterJournalTransactions,   filterJournalPostings,-  filterJournalPostingAmounts,+  filterJournalAmounts,+  filterTransactionAmounts,   filterPostingAmount,   -- * Querying   journalAccountNames,@@ -45,6 +46,7 @@   journalEquityAccountQuery,   journalCashAccountQuery,   -- * Misc+  canonicalStyles,   matchpats,   nullctx,   nulljournal,@@ -58,6 +60,7 @@ -- import Data.Map (findWithDefault) import Data.Maybe import Data.Ord+import Safe (headMay) import Data.Time.Calendar import Data.Time.LocalTime import Data.Tree@@ -131,7 +134,7 @@                       }  nullctx :: JournalContext-nullctx = Ctx { ctxYear = Nothing, ctxCommodityAndStyle = Nothing, ctxAccount = [], ctxAliases = [] }+nullctx = Ctx { ctxYear = Nothing, ctxDefaultCommodityAndStyle = Nothing, ctxAccount = [], ctxAliases = [] }  journalFilePath :: Journal -> FilePath journalFilePath = fst . mainfile@@ -143,19 +146,19 @@ mainfile = headDef ("", "") . files  addTransaction :: Transaction -> Journal -> Journal-addTransaction t l0 = l0 { jtxns = t : jtxns l0 }+addTransaction t j = j { jtxns = t : jtxns j }  addModifierTransaction :: ModifierTransaction -> Journal -> Journal-addModifierTransaction mt l0 = l0 { jmodifiertxns = mt : jmodifiertxns l0 }+addModifierTransaction mt j = j { jmodifiertxns = mt : jmodifiertxns j }  addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal-addPeriodicTransaction pt l0 = l0 { jperiodictxns = pt : jperiodictxns l0 }+addPeriodicTransaction pt j = j { jperiodictxns = pt : jperiodictxns j }  addHistoricalPrice :: HistoricalPrice -> Journal -> Journal-addHistoricalPrice h l0 = l0 { historical_prices = h : historical_prices l0 }+addHistoricalPrice h j = j { historical_prices = h : historical_prices j }  addTimeLogEntry :: TimeLogEntry -> Journal -> Journal-addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : open_timelog_entries l0 }+addTimeLogEntry tle j = j { open_timelog_entries = tle : open_timelog_entries j }  -- | Unique transaction descriptions used in this journal. journalDescriptions :: Journal -> [String]@@ -231,6 +234,10 @@ ------------------------------------------------------------------------------- -- filtering V2 +-- | Keep only transactions matching the query expression.+filterJournalTransactions :: Query -> Journal -> Journal+filterJournalTransactions q j@Journal{jtxns=ts} = j{jtxns=filter (q `matchesTransaction`) ts}+ -- | Keep only postings matching the query expression. -- This can leave unbalanced transactions. filterJournalPostings :: Query -> Journal -> Journal@@ -238,21 +245,20 @@     where       filtertransactionpostings t@Transaction{tpostings=ps} = t{tpostings=filter (q `matchesPosting`) ps} --- Within each posting's amount, keep only the parts matching the query.+-- | Within each posting's amount, keep only the parts matching the query. -- This can leave unbalanced transactions.-filterJournalPostingAmounts :: Query -> Journal -> Journal-filterJournalPostingAmounts q j@Journal{jtxns=ts} = j{jtxns=map filtertransactionpostings ts}-    where-      filtertransactionpostings t@Transaction{tpostings=ps} = t{tpostings=map (filterPostingAmount q) ps}+filterJournalAmounts :: Query -> Journal -> Journal+filterJournalAmounts q j@Journal{jtxns=ts} = j{jtxns=map (filterTransactionAmounts q) ts} +-- | Filter out all parts of this transaction's amounts which do not match the query.+-- This can leave the transaction unbalanced.+filterTransactionAmounts :: Query -> Transaction -> Transaction+filterTransactionAmounts q t@Transaction{tpostings=ps} = t{tpostings=map (filterPostingAmount q) ps}+ -- | Filter out all parts of this posting's amount which do not match the query. filterPostingAmount :: Query -> Posting -> Posting filterPostingAmount q p@Posting{pamount=Mixed as} = p{pamount=Mixed $ filter (q `matchesAmount`) as} --- | Keep only transactions matching the query expression.-filterJournalTransactions :: Query -> Journal -> Journal-filterJournalTransactions q j@Journal{jtxns=ts} = j{jtxns=filter (q `matchesTransaction`) ts}- {- ------------------------------------------------------------------------------- -- filtering V1@@ -379,22 +385,36 @@ -}  -- | 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}+journalApplyAliases :: [AccountAlias] -> Journal -> Journal+journalApplyAliases aliases j@Journal{jtxns=ts} =+  -- (if null aliases+  --  then id+  --  else (dbgtrace $+  --        "applying additional command-line aliases:\n"+  --        ++ chomp (unlines $ map (" "++) $ lines $ ppShow aliases))) $+  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: check -- all transactions balance, canonicalise amount formats, close any open--- timelog entries and so on.-journalFinalise :: ClockTime -> LocalTime -> FilePath -> String -> JournalContext -> Journal -> Either String Journal-journalFinalise tclock tlocal path txt ctx j@Journal{files=fs} = do+-- timelog entries, maybe check balance assertions and so on.+journalFinalise :: ClockTime -> LocalTime -> FilePath -> String -> JournalContext -> Bool -> Journal -> Either String Journal+journalFinalise tclock tlocal path txt ctx assrt j@Journal{files=fs} = do   (journalBalanceTransactions $     journalCanonicaliseAmounts $-    journalCloseTimeLogEntries tlocal-    j{files=(path,txt):fs, filereadtime=tclock, jContext=ctx})-  >>= journalCheckBalanceAssertions+    journalCloseTimeLogEntries tlocal $+    j{ files=(path,txt):fs+     , filereadtime=tclock+     , jContext=ctx+     , jtxns=reverse $ jtxns j -- NOTE: see addTransaction+     , jmodifiertxns=reverse $ jmodifiertxns j -- NOTE: see addModifierTransaction+     , jperiodictxns=reverse $ jperiodictxns j -- NOTE: see addPeriodicTransaction+     , historical_prices=reverse $ historical_prices j -- NOTE: see addHistoricalPrice+     , open_timelog_entries=reverse $ open_timelog_entries j -- NOTE: see addTimeLogEntry+     })+  >>= if assrt then journalCheckBalanceAssertions else return  -- | Check any balance assertions in the journal and return an error -- message if any of them fail.@@ -423,26 +443,29 @@ -- If it does, return the new balance, otherwise add an error to the -- error list. Intended to be called from a fold. checkBalanceAssertion :: ([String],MixedAmount) -> [Posting] -> ([String],MixedAmount)-checkBalanceAssertion (errs,bal) ps-  | null ps = (errs,bal)-  | isNothing assertion = (errs,bal)+checkBalanceAssertion (errs,startbal) ps+  | null ps = (errs,startbal)+  | isNothing assertion = (errs,startbal)   |     -- bal' /= assertedbal  -- MixedAmount's Eq instance currently gets confused by different precisions-    not $ isReallyZeroMixedAmount (bal' - assertedbal)-      = (errs++[err], bal')-  | otherwise = (errs,bal')+    not $ isReallyZeroMixedAmount (bal - assertedbal) = (errs++[err], bal)+  | otherwise = (errs,bal)   where     p = last ps     assertion = pbalanceassertion p-    Just assertedbal = assertion-    bal' = sum $ [bal] ++ map pamount ps-    err = printf "Balance assertion failed for account %s on %s\n%sAfter posting:\n   %s\nexpected balance is %s, actual balance was %s."+    Just assertedbal = dbg2 "assertedbal" assertion+    assertedcomm = dbg2 "assertedcomm" $ maybe "" acommodity $ headMay $ amounts assertedbal+    fullbal = dbg2 "fullbal" $ sum $ [dbg2 "startbal" startbal] ++ map pamount ps+    singlebal = dbg2 "singlebal" $ filterMixedAmount (\a -> acommodity a == assertedcomm) fullbal+    bal = singlebal -- check single-commodity balance like Ledger; maybe add == FULLBAL later+    err = printf "Balance assertion failed for account %s on %s\n%sAfter posting:\n   %s\nexpected balance in commodity \"%s\" is %s, calculated balance was %s."                  (paccount p)                  (show $ postingDate p)                  (maybe "" (("In transaction:\n"++).show) $ ptransaction p)                  (show p)+                 assertedcomm                  (showMixedAmount assertedbal)-                 (showMixedAmount bal')+                 (showMixedAmount singlebal)  -- Given a sequence of postings to a single account, split it into -- sub-sequences consisting of ordinary postings followed by a single@@ -454,7 +477,7 @@   | otherwise = (ps'++[head rest]):splitAssertions (tail rest)   where     (ps',rest) = break (isJust . pbalanceassertion) ps-    + -- | Fill in any missing amounts and check that all journal transactions -- balance, or return an error message. This is done after parsing all -- amounts and working out the canonical commodities, since balancing@@ -473,12 +496,34 @@ journalCanonicaliseAmounts j@Journal{jtxns=ts} = j''     where       j'' = j'{jtxns=map fixtransaction ts}-      j' = j{jcommoditystyles = canonicalStyles $ journalAmounts j}+      j' = j{jcommoditystyles = canonicalStyles $ dbgAt 8 "journalAmounts" $ journalAmounts j}       fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}       fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}       fixmixedamount (Mixed as) = Mixed $ map fixamount as       fixamount a@Amount{acommodity=c} = a{astyle=journalCommodityStyle j' c} +-- | Given a list of amounts in parse order, build a map from commodities+-- to canonical display styles for amounts in that commodity.+canonicalStyles :: [Amount] -> M.Map Commodity AmountStyle+canonicalStyles amts = M.fromList commstyles+  where+    samecomm = \a1 a2 -> acommodity a1 == acommodity a2+    commamts = [(acommodity $ head as, as) | as <- groupBy samecomm $ sortBy (comparing acommodity) amts]+    commstyles = [(c, canonicalStyleFrom $ map astyle as) | (c,as) <- commamts]++-- Given an ordered list of amount styles for a commodity, build a canonical style.+canonicalStyleFrom :: [AmountStyle] -> AmountStyle+canonicalStyleFrom [] = amountstyle+canonicalStyleFrom ss@(first:_) =+  first{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}+  where+    -- precision is the maximum of all precisions seen+    prec = maximum $ map asprecision ss+    -- find the first decimal point and the first digit group style seen,+    -- or use defaults.+    mdec  = Just $ headDef '.' $ catMaybes $ map asdecimalpoint ss+    mgrps = maybe Nothing Just $ headMay $ catMaybes $ map asdigitgroups ss+ -- | Get this journal's canonical amount style for the given commodity, or the null style. journalCommodityStyle :: Journal -> Commodity -> AmountStyle journalCommodityStyle j c = M.findWithDefault amountstyle c $ jcommoditystyles j@@ -623,10 +668,11 @@ --     liabilities:debts  $1 --     assets:bank:checking ---Right samplejournal = journalBalanceTransactions $ +Right samplejournal = journalBalanceTransactions $          nulljournal          {jtxns = [            txnTieKnot $ Transaction {+             tsourcepos=nullsourcepos,              tdate=parsedate "2008/01/01",              tdate2=Nothing,              tstatus=False,@@ -642,6 +688,7 @@            }           ,            txnTieKnot $ Transaction {+             tsourcepos=nullsourcepos,              tdate=parsedate "2008/06/01",              tdate2=Nothing,              tstatus=False,@@ -657,6 +704,7 @@            }           ,            txnTieKnot $ Transaction {+             tsourcepos=nullsourcepos,              tdate=parsedate "2008/06/02",              tdate2=Nothing,              tstatus=False,@@ -672,6 +720,7 @@            }           ,            txnTieKnot $ Transaction {+             tsourcepos=nullsourcepos,              tdate=parsedate "2008/06/03",              tdate2=Nothing,              tstatus=True,@@ -687,6 +736,7 @@            }           ,            txnTieKnot $ Transaction {+             tsourcepos=nullsourcepos,              tdate=parsedate "2008/12/31",              tdate2=Nothing,              tstatus=False,

@@ -43,7 +43,7 @@ ledgerFromJournal q j = nullledger{ljournal=j'', laccounts=as}   where     (q',depthq)  = (filterQuery (not . queryIsDepth) q, filterQuery queryIsDepth q)-    j'  = filterJournalPostingAmounts (filterQuery queryIsSym q) $ -- remove amount parts which the query's sym: terms would exclude+    j'  = filterJournalAmounts (filterQuery queryIsSym q) $ -- remove amount parts which the query's sym: terms would exclude           filterJournalPostings q' j     as  = accountsFromPostings $ journalPostings j'     j'' = filterJournalPostings depthq j'

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} module Hledger.Data.OutputFormat (           parseStringFormat         , formatsp@@ -11,7 +12,7 @@ import Data.Char (isPrint) import Data.Maybe import Test.HUnit-import Text.ParserCombinators.Parsec+import Text.Parsec import Text.Printf  import Hledger.Data.Types@@ -34,7 +35,7 @@ Parsers -} -field :: GenParser Char st HledgerFormatField+field :: Stream [Char] m Char => ParsecT [Char] st m HledgerFormatField field = do         try (string "account" >> return AccountField)     <|> try (string "depth_spacer" >> return DepthSpacerField)@@ -43,7 +44,7 @@     <|> try (string "total" >> return TotalField)     <|> try (many1 digit >>= (\s -> return $ FieldNo $ read s)) -formatField :: GenParser Char st OutputFormat+formatField :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat formatField = do     char '%'     leftJustified <- optionMaybe (char '-')@@ -58,7 +59,7 @@         Just text -> Just m where ((m,_):_) = readDec text         _ -> Nothing -formatLiteral :: GenParser Char st OutputFormat+formatLiteral :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat formatLiteral = do     s <- many1 c     return $ FormatLiteral s@@ -67,12 +68,12 @@       c =     (satisfy isPrintableButNotPercentage <?> "printable character")           <|> try (string "%%" >> return '%') -formatp :: GenParser Char st OutputFormat+formatp :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat formatp =         formatField     <|> formatLiteral -formatsp :: GenParser Char st [OutputFormat]+formatsp :: Stream [Char] m Char => ParsecT [Char] st m [OutputFormat] formatsp = many formatp  testFormat :: OutputFormat -> String -> String -> Assertion

@@ -37,6 +37,7 @@   joinAccountNames,   concatAccountNames,   accountNameApplyAliases,+  accountNameApplyOneAlias,   -- * arithmetic   sumPostings,   -- * rendering@@ -79,11 +80,12 @@ posting = nullposting  post :: AccountName -> Amount -> Posting-post acct amt = posting {paccount=acct, pamount=mixed amt}+post acct amt = posting {paccount=acct, pamount=Mixed [amt]} +-- XXX once rendered user output, but just for debugging now; clean up showPosting :: Posting -> String showPosting p@Posting{paccount=a,pamount=amt,ptype=t} =-    unlines $ [concatTopPadded [showaccountname a ++ " ", showamount amt, showComment (pcomment p)]]+    unlines $ [concatTopPadded [show (postingDate p) ++ " ", showaccountname a ++ " ", showamount amt, showComment (pcomment p)]]     where       ledger3ishlayout = False       acctnamewidth = if ledger3ishlayout then 25 else 22@@ -121,7 +123,7 @@ -- there is no parent transaction. postingDate :: Posting -> Day postingDate p = fromMaybe txndate $ pdate p-    where +    where       txndate = maybe nulldate tdate $ ptransaction p  -- | Get a posting's secondary (secondary) date, which is the first of:@@ -217,14 +219,22 @@ concatAccountNames as = accountNameWithPostingType t $ intercalate ":" $ map accountNameWithoutPostingType as     where t = headDef RegularPosting $ filter (/= RegularPosting) $ map accountNamePostingType as +-- | Rewrite an account name using all applicable aliases from the given list, in sequence.+accountNameApplyAliases :: [AccountAlias] -> AccountName -> AccountName+accountNameApplyAliases aliases a = accountNameWithPostingType atype aname'+  where+    (aname,atype) = (accountNameWithoutPostingType a, accountNamePostingType a)+    matchingaliases = filter (\(re,_) -> regexMatchesCI re aname) aliases+    aname' = foldl (flip (uncurry regexReplaceCI)) aname matchingaliases+ -- | 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+accountNameApplyOneAlias :: [AccountAlias] -> AccountName -> AccountName+accountNameApplyOneAlias aliases a = accountNameWithPostingType atype aname'+  where+    (aname,atype) = (accountNameWithoutPostingType a, accountNamePostingType a)+    firstmatchingalias = headDef Nothing $ map Just $ filter (\(re,_) -> regexMatchesCI re aname) aliases+    applyAlias = uncurry regexReplaceCI+    aname' = maybe id applyAlias firstmatchingalias $ aname  tests_Hledger_Data_Posting = TestList [ @@ -250,4 +260,4 @@     concatAccountNames ["a","(b)","[c:d]"] `is` "(a:b:c:d)"   ]- +

@@ -45,7 +45,7 @@ boolopt = inRawOpts  maybestringopt :: String -> RawOpts -> Maybe String-maybestringopt name = maybe Nothing (Just . stripquotes) . lookup name+maybestringopt name = maybe Nothing (Just . stripquotes) . lookup name . reverse  stringopt :: String -> RawOpts -> String stringopt name = fromMaybe "" . maybestringopt name

@@ -24,17 +24,17 @@ import Hledger.Data.Posting import Hledger.Data.Transaction -instance Show TimeLogEntry where +instance Show TimeLogEntry where     show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t) -instance Show TimeLogCode where +instance Show TimeLogCode where     show SetBalance = "b"     show SetRequiredHours = "h"     show In = "i"     show Out = "o"     show FinalOut = "O" -instance Read TimeLogCode where +instance Read TimeLogCode where     readsPrec _ ('b' : xs) = [(SetBalance, xs)]     readsPrec _ ('h' : xs) = [(SetRequiredHours, xs)]     readsPrec _ ('i' : xs) = [(In, xs)]@@ -51,7 +51,7 @@     | odate > idate = entryFromTimeLogInOut i o' : timeLogEntriesToTransactions now [i',o]     | otherwise = [entryFromTimeLogInOut i o]     where-      o = TimeLogEntry Out end ""+      o = TimeLogEntry (tlsourcepos i) Out end ""       end = if itime > now then itime else now       (itime,otime) = (tldatetime i,tldatetime o)       (idate,odate) = (localDay itime,localDay otime)@@ -72,18 +72,19 @@ entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Transaction entryFromTimeLogInOut i o     | otime >= itime = t-    | otherwise = +    | otherwise =         error' $ "clock-out time less than clock-in time in:\n" ++ showTransaction t     where       t = Transaction {-            tdate         = idate,-            tdate2 = Nothing,-            tstatus       = True,-            tcode         = "",-            tdescription  = showtime itod ++ "-" ++ showtime otod,-            tcomment      = "",-            ttags     = [],-            tpostings = ps,+            tsourcepos   = tlsourcepos i,+            tdate        = idate,+            tdate2       = Nothing,+            tstatus      = True,+            tcode        = "",+            tdescription = showtime itod ++ "-" ++ showtime otod,+            tcomment     = "",+            ttags        = [],+            tpostings    = ps,             tpreceding_comment_lines=""           }       showtime = take 5 . show@@ -107,7 +108,7 @@      let now = utcToLocalTime tz now'          nowstr = showtime now          yesterday = prevday today-         clockin = TimeLogEntry In+         clockin = TimeLogEntry nullsourcepos In          mktime d = LocalTime d . fromMaybe midnight . parseTime defaultTimeLocale "%H:%M:%S"          showtime = formatTime defaultTimeLocale "%H:%M"          assertEntriesGiveStrings name es ss = assertEqual name ss (map tdescription $ timeLogEntriesToTransactions now es)@@ -118,8 +119,8 @@      assertEntriesGiveStrings "split multi-day sessions at each midnight"                                   [clockin (mktime (addDays (-2) today) "23:00:00") ""]                                   ["23:00-23:59","00:00-23:59","00:00-"++nowstr]-     assertEntriesGiveStrings "auto-clock-out if needed" -                                  [clockin (mktime today "00:00:00") ""] +     assertEntriesGiveStrings "auto-clock-out if needed"+                                  [clockin (mktime today "00:00:00") ""]                                   ["00:00-"++nowstr]      let future = utcToLocalTime tz $ addUTCTime 100 now'          futurestr = showtime future

@@ -9,6 +9,7 @@  module Hledger.Data.Transaction (   -- * Transaction+  nullsourcepos,   nulltransaction,   txnTieKnot,   -- settxn,@@ -39,6 +40,7 @@ import Test.HUnit import Text.Printf import qualified Data.Map as Map+import Text.Parsec.Pos  import Hledger.Utils import Hledger.Data.Types@@ -48,19 +50,23 @@  instance Show Transaction where show = showTransactionUnelided -instance Show ModifierTransaction where +instance Show ModifierTransaction where     show t = "= " ++ mtvalueexpr t ++ "\n" ++ unlines (map show (mtpostings t)) -instance Show PeriodicTransaction where +instance Show PeriodicTransaction where     show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t)) +nullsourcepos :: SourcePos+nullsourcepos = initialPos ""+ nulltransaction :: Transaction nulltransaction = Transaction {+                    tsourcepos=nullsourcepos,                     tdate=nulldate,                     tdate2=Nothing,-                    tstatus=False, -                    tcode="", -                    tdescription="", +                    tstatus=False,+                    tcode="",+                    tdescription="",                     tcomment="",                     ttags=[],                     tpostings=[],@@ -122,7 +128,7 @@       ]  ] --- XXX overlaps showPosting+-- cf showPosting showTransaction' :: Bool -> Transaction -> String showTransaction' elide t =     unlines $ [descriptionline]@@ -280,7 +286,7 @@       ramounts  = map pamount rwithamounts       bvamounts = map pamount bvwithamounts       t' = t{tpostings=map inferamount ps}-          where +          where             inferamount p | not (hasAmount p) && isReal p            = p{pamount = costOfMixedAmount (- sum ramounts)}                           | not (hasAmount p) && isBalancedVirtual p = p{pamount = costOfMixedAmount (- sum bvamounts)}                           | otherwise                             = p@@ -376,7 +382,7 @@         ,"    assets:checking"         ,""         ])-       (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []+       (let t = Transaction nullsourcepos (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []                 [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18], ptransaction=Just t}                 ,posting{paccount="assets:checking", pamount=Mixed [usd (-47.18)], ptransaction=Just t}                 ] ""@@ -390,7 +396,7 @@         ,"    assets:checking               $-47.18"         ,""         ])-       (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []+       (let t = Transaction nullsourcepos (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []                 [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18], ptransaction=Just t}                 ,posting{paccount="assets:checking", pamount=Mixed [usd (-47.18)], ptransaction=Just t}                 ] ""@@ -406,7 +412,7 @@         ,""         ])        (showTransaction-        (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []+        (txnTieKnot $ Transaction nullsourcepos (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []          [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18]}          ,posting{paccount="assets:checking", pamount=Mixed [usd (-47.19)]}          ] ""))@@ -419,7 +425,7 @@         ,""         ])        (showTransaction-        (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []+        (txnTieKnot $ Transaction nullsourcepos (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []          [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18]}          ] "")) @@ -431,7 +437,7 @@         ,""         ])        (showTransaction-        (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []+        (txnTieKnot $ Transaction nullsourcepos (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []          [posting{paccount="expenses:food:groceries", pamount=missingmixedamt}          ] "")) @@ -444,7 +450,7 @@         ,""         ])        (showTransaction-        (txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" []+        (txnTieKnot $ Transaction nullsourcepos (parsedate "2010/01/01") Nothing False "" "x" "" []          [posting{paccount="a", pamount=Mixed [num 1 `at` (usd 2 `withPrecision` 0)]}          ,posting{paccount="b", pamount= missingmixedamt}          ] ""))@@ -452,19 +458,19 @@   ,"balanceTransaction" ~: do      assertBool "detect unbalanced entry, sign error"                     (isLeft $ balanceTransaction Nothing-                           (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" []+                           (Transaction nullsourcepos (parsedate "2007/01/28") Nothing False "" "test" "" []                             [posting{paccount="a", pamount=Mixed [usd 1]}                             ,posting{paccount="b", pamount=Mixed [usd 1]}                             ] ""))       assertBool "detect unbalanced entry, multiple missing amounts"                     (isLeft $ balanceTransaction Nothing-                           (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" []+                           (Transaction nullsourcepos (parsedate "2007/01/28") Nothing False "" "test" "" []                             [posting{paccount="a", pamount=missingmixedamt}                             ,posting{paccount="b", pamount=missingmixedamt}                             ] "")) -     let e = balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "" "" []+     let e = balanceTransaction Nothing (Transaction nullsourcepos (parsedate "2007/01/28") Nothing False "" "" "" []                            [posting{paccount="a", pamount=Mixed [usd 1]}                            ,posting{paccount="b", pamount=missingmixedamt}                            ] "")@@ -475,7 +481,7 @@                         Right e' -> (pamount $ last $ tpostings e')                         Left _ -> error' "should not happen") -     let e = balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []+     let e = balanceTransaction Nothing (Transaction nullsourcepos (parsedate "2011/01/01") Nothing False "" "" "" []                            [posting{paccount="a", pamount=Mixed [usd 1.35]}                            ,posting{paccount="b", pamount=Mixed [eur (-1)]}                            ] "")@@ -487,49 +493,49 @@                         Left _ -> error' "should not happen")       assertBool "balanceTransaction balances based on cost if there are unit prices" (isRight $-       balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []+       balanceTransaction Nothing (Transaction nullsourcepos (parsedate "2011/01/01") Nothing False "" "" "" []                            [posting{paccount="a", pamount=Mixed [usd 1 `at` eur 2]}                            ,posting{paccount="a", pamount=Mixed [usd (-2) `at` eur 1]}                            ] ""))       assertBool "balanceTransaction balances based on cost if there are total prices" (isRight $-       balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []+       balanceTransaction Nothing (Transaction nullsourcepos (parsedate "2011/01/01") Nothing False "" "" "" []                            [posting{paccount="a", pamount=Mixed [usd 1    @@ eur 1]}                            ,posting{paccount="a", pamount=Mixed [usd (-2) @@ eur 1]}                            ] ""))    ,"isTransactionBalanced" ~: do-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []+     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing False "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}              ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t}              ] ""      assertBool "detect balanced" (isTransactionBalanced Nothing t)-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []+     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing False "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}              ,posting{paccount="c", pamount=Mixed [usd (-1.01)], ptransaction=Just t}              ] ""      assertBool "detect unbalanced" (not $ isTransactionBalanced Nothing t)-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []+     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing False "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}              ] ""      assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced Nothing t)-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []+     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing False "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 0], ptransaction=Just t}              ] ""      assertBool "one zero posting is considered balanced for now" (isTransactionBalanced Nothing t)-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []+     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing False "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}              ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t}              ,posting{paccount="d", pamount=Mixed [usd 100], ptype=VirtualPosting, ptransaction=Just t}              ] ""      assertBool "virtual postings don't need to balance" (isTransactionBalanced Nothing t)-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []+     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing False "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}              ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t}              ,posting{paccount="d", pamount=Mixed [usd 100], ptype=BalancedVirtualPosting, ptransaction=Just t}              ] ""      assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced Nothing t)-     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []+     let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing False "" "a" "" []              [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t}              ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t}              ,posting{paccount="d", pamount=Mixed [usd 100], ptype=BalancedVirtualPosting, ptransaction=Just t}

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}+{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances #-} {-|  Most data types are defined here to avoid import cycles.@@ -21,12 +21,19 @@ where import Control.Monad.Error (ErrorT) import Data.Data+#ifndef DOUBLE+import Data.Decimal+import Text.Blaze (ToMarkup(..))+#endif import qualified Data.Map as M import Data.Time.Calendar import Data.Time.LocalTime import System.Time (ClockTime(..))+import Text.Parsec.Pos +import Hledger.Utils.Regex + type SmartDate = (String,String,String)  data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show)@@ -41,11 +48,28 @@  type AccountName = String +type AccountAlias = (Regexp,Replacement)+ data Side = L | R deriving (Eq,Show,Read,Ord,Typeable,Data)  type Commodity = String-      ++-- | The basic numeric type used in amounts. Different implementations+-- can be selected via cabal flag for testing and benchmarking purposes.+numberRepresentation :: String+#ifdef DOUBLE type Quantity = Double+numberRepresentation = "Double"+#else+type Quantity = Decimal+deriving instance Data (Quantity)+-- The following is for hledger-web, and requires blaze-markup.+-- Doing it here avoids needing a matching flag on the hledger-web package.+instance ToMarkup (Quantity) + where+   toMarkup = toMarkup . show+numberRepresentation = "Decimal"+#endif  -- | An amount's price (none, per unit, or total) in another commodity. -- Note the price should be a positive number, although this is not enforced.@@ -56,11 +80,19 @@       ascommodityside :: Side,       -- ^ does the symbol appear on the left or the right ?       ascommodityspaced :: Bool,     -- ^ space between symbol and quantity ?       asprecision :: Int,            -- ^ number of digits displayed after the decimal point-      asdecimalpoint :: Char,        -- ^ character used as decimal point-      asseparator :: Char,           -- ^ character used for separating digit groups (eg thousands)-      asseparatorpositions :: [Int]  -- ^ positions of digit group separators, counting leftward from decimal point+      asdecimalpoint :: Maybe Char,  -- ^ character used as decimal point: period or comma. Nothing means "unspecified, use default"+      asdigitgroups :: Maybe DigitGroupStyle -- ^ style for displaying digit groups, if any } deriving (Eq,Ord,Read,Show,Typeable,Data) +-- | A style for displaying digit groups in the integer part of a+-- floating point number. It consists of the character used to+-- separate groups (comma or period, whichever is not used as decimal+-- point), and the size of each group, starting with the one nearest+-- the decimal point. The last group size is assumed to repeat. Eg,+-- comma between thousands is DigitGroups ',' [3].+data DigitGroupStyle = DigitGroups Char [Int]+  deriving (Eq,Ord,Read,Show,Typeable,Data)+ data Amount = Amount {       acommodity :: Commodity,       aquantity :: Quantity,@@ -95,6 +127,7 @@     (==) (Posting a1 b1 c1 d1 e1 f1 g1 h1 i1 _) (Posting a2 b2 c2 d2 e2 f2 g2 h2 i2 _) =  a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 && f1==f2 && g1==g2 && h1==h2 && i1==i2  data Transaction = Transaction {+      tsourcepos :: SourcePos,       tdate :: Day,       tdate2 :: Maybe Day,       tstatus :: Bool,  -- XXX tcleared ?@@ -119,6 +152,7 @@ data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Typeable,Data)  data TimeLogEntry = TimeLogEntry {+      tlsourcepos :: SourcePos,       tlcode :: TimeLogCode,       tldatetime :: LocalTime,       tlcomment :: String@@ -138,11 +172,11 @@ -- is saved for later use by eg the add command. data JournalContext = Ctx {       ctxYear      :: !(Maybe Year)      -- ^ the default year most recently specified with Y-    , ctxCommodityAndStyle :: !(Maybe (Commodity,AmountStyle)) -- ^ the default commodity and amount style most recently specified with D+    , ctxDefaultCommodityAndStyle :: !(Maybe (Commodity,AmountStyle)) -- ^ the default commodity and amount style most recently specified with D     , 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+    , ctxAliases   :: ![AccountAlias]   -- ^ the current list of account name aliases in effect     } deriving (Read, Show, Eq, Data, Typeable)  deriving instance Data (ClockTime)@@ -159,7 +193,7 @@       files :: [(FilePath, String)],        -- ^ the file path and raw text of the main and                                             -- any included journal files. The main file is                                             -- first followed by any included files in the-                                            -- order encountered (XXX reversed, cf journalAddFile).+                                            -- order encountered.       filereadtime :: ClockTime,            -- ^ when this journal was last read from its file(s)       jcommoditystyles :: M.Map Commodity AmountStyle  -- ^ how to display amounts in each commodity     } deriving (Eq, Typeable, Data)@@ -179,10 +213,10 @@      -- quickly check if this reader can probably handle the given file path and file content     ,rDetector :: FilePath -> String -> Bool      -- parse the given string, using the given parse rules file if any, returning a journal or error aware of the given file path-    ,rParser   :: Maybe FilePath -> FilePath -> String -> ErrorT String IO Journal+    ,rParser   :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal     } -instance Show Reader where show r = "Reader for "++rFormat r+instance Show Reader where show r = rFormat r ++ " reader"  -- format strings 

@@ -19,10 +19,14 @@   queryIsAcct,   queryIsDepth,   queryIsDate,+  queryIsDate2,+  queryIsDateOrDate2,   queryIsStartDateOnly,   queryIsSym,   queryStartDate,+  queryEndDate,   queryDateSpan,+  queryDateSpan',   queryDepth,   queryEmpty,   inAccount,@@ -45,7 +49,8 @@ import Data.Time.Calendar import Safe (readDef, headDef, headMay) import Test.HUnit-import Text.ParserCombinators.Parsec+-- import Text.ParserCombinators.Parsec+import Text.Parsec hiding (Empty)  import Hledger.Utils import Hledger.Data.Types@@ -206,7 +211,7 @@     ,"desc"     ,"acct"     ,"date"-    ,"edate"+    ,"date2"     ,"status"     ,"cur"     ,"real"@@ -227,7 +232,8 @@ -- query :: GenParser String () Query -- query = undefined --- | Parse a single query term as either a query or a query option.+-- | Parse a single query term as either a query or a query option,+-- or raise an error if it has invalid syntax. parseQueryTerm :: Day -> String -> Either Query QueryOpt parseQueryTerm _ ('i':'n':'a':'c':'c':'t':'o':'n':'l':'y':':':s) = Right $ QueryOptInAcctOnly s parseQueryTerm _ ('i':'n':'a':'c':'c':'t':':':s) = Right $ QueryOptInAcct s@@ -237,12 +243,12 @@ parseQueryTerm _ ('c':'o':'d':'e':':':s) = Left $ Code s parseQueryTerm _ ('d':'e':'s':'c':':':s) = Left $ Desc s parseQueryTerm _ ('a':'c':'c':'t':':':s) = Left $ Acct s+parseQueryTerm d ('d':'a':'t':'e':'2':':':s) =+        case parsePeriodExpr d s of Left e         -> error' $ "\"date2:"++s++"\" gave a "++showDateParseError e+                                    Right (_,span) -> Left $ Date2 span parseQueryTerm d ('d':'a':'t':'e':':':s) =-        case parsePeriodExpr d s of Left _ -> Left None -- XXX should warn+        case parsePeriodExpr d s of Left e         -> error' $ "\"date:"++s++"\" gave a "++showDateParseError e                                     Right (_,span) -> Left $ Date span-parseQueryTerm d ('e':'d':'a':'t':'e':':':s) =-        case parsePeriodExpr d s of Left _ -> Left None -- XXX should warn-                                    Right (_,span) -> Left $ Date2 span parseQueryTerm _ ('s':'t':'a':'t':'u':'s':':':s) = Left $ Status $ parseStatus s parseQueryTerm _ ('r':'e':'a':'l':':':s) = Left $ Real $ parseBool s parseQueryTerm _ ('a':'m':'t':':':s) = Left $ Amt ord q where (ord, q) = parseAmountQueryTerm s@@ -274,7 +280,7 @@  ]  -data OrdPlus = Lt | Gt | Eq | AbsLt | AbsGt | AbsEq+data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq | AbsEq  deriving (Show,Eq,Data,Typeable)  -- can fail@@ -282,21 +288,29 @@ parseAmountQueryTerm s' =   case s' of     -- feel free to do this a smarter way-    ""        -> err-    '<':'+':s -> (Lt, readDef err s)-    '>':'+':s -> (Gt, readDef err s)-    '=':'+':s -> (Eq, readDef err s)-    '+':s     -> (Eq, readDef err s)-    '<':'-':s -> (Lt, negate $ readDef err s)-    '>':'-':s -> (Gt, negate $ readDef err s)-    '=':'-':s -> (Eq, negate $ readDef err s)-    '-':s     -> (Eq, negate $ readDef err s)-    '<':s     -> let n = readDef err s in case n of 0 -> (Lt, 0)-                                                    _ -> (AbsLt, n)-    '>':s     -> let n = readDef err s in case n of 0 -> (Gt, 0)-                                                    _ -> (AbsGt, n)-    '=':s     -> (AbsEq, readDef err s)-    s         -> (AbsEq, readDef err s)+    ""              -> err+    '<':'+':s       -> (Lt, readDef err s)+    '<':'=':'+':s   -> (LtEq, readDef err s)+    '>':'+':s       -> (Gt, readDef err s)+    '>':'=':'+':s   -> (GtEq, readDef err s)+    '=':'+':s       -> (Eq, readDef err s)+    '+':s           -> (Eq, readDef err s)+    '<':'-':s       -> (Lt, negate $ readDef err s)+    '<':'=':'-':s   -> (LtEq, negate $ readDef err s)+    '>':'-':s       -> (Gt, negate $ readDef err s)+    '>':'=':'-':s   -> (GtEq, negate $ readDef err s)+    '=':'-':s       -> (Eq, negate $ readDef err s)+    '-':s           -> (Eq, negate $ readDef err s)+    '<':'=':s       -> let n = readDef err s in case n of 0 -> (LtEq, 0)+                                                          _ -> (AbsLtEq, n)+    '<':s           -> let n = readDef err s in case n of 0 -> (Lt, 0)+                                                          _ -> (AbsLt, n)+    '>':'=':s       -> let n = readDef err s in case n of 0 -> (GtEq, 0)+                                                          _ -> (AbsGtEq, n)+    '>':s           -> let n = readDef err s in case n of 0 -> (Gt, 0)+                                                          _ -> (AbsGt, n)+    '=':s           -> (AbsEq, readDef err s)+    s               -> (AbsEq, readDef err s)   where     err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a (optionally signed) numeric quantity: " ++ s' @@ -308,7 +322,7 @@     ">10000.10" `gives` (AbsGt,10000.1)     "=0.23" `gives` (AbsEq,0.23)     "0.23" `gives` (AbsEq,0.23)-    "=+0.23" `gives` (Eq,0.23)+    "<=+0.23" `gives` (LtEq,0.23)     "-0.23" `gives` (Eq,(-0.23))   ] @@ -317,18 +331,18 @@            | otherwise    = (s, Nothing)            where (n,v) = break (=='=') s --- | Parse the boolean value part of a "status:" query, allowing "*" as--- another way to spell True, similar to the journal file format.+-- -- , treating "*" or "!" as synonyms for "1".+-- | Parse the boolean value part of a "status:" query. parseStatus :: String -> Bool-parseStatus s = s `elem` (truestrings ++ ["*"])+parseStatus s = s `elem` (truestrings) -- ++ ["*","!"]) --- | Parse the boolean value part of a "status:" query. A true value can--- be spelled as "1", "t" or "true".+-- | Parse the boolean value part of a "status:" query. "1" means true,+-- anything else will be parsed as false without error. parseBool :: String -> Bool parseBool s = s `elem` truestrings  truestrings :: [String]-truestrings = ["1","t","true"]+truestrings = ["1"]  simplifyQuery :: Query -> Query simplifyQuery q =@@ -349,6 +363,7 @@                      -- all queryIsDate qs = Date $ spansUnion $ mapMaybe queryTermDateSpan qs  ?                      | otherwise = Or $ map simplify $ filter (/=None) qs     simplify (Date (DateSpan Nothing Nothing)) = Any+    simplify (Date2 (DateSpan Nothing Nothing)) = Any     simplify q = q  tests_simplifyQuery = [@@ -403,9 +418,17 @@  queryIsDate :: Query -> Bool queryIsDate (Date _) = True-queryIsDate (Date2 _) = True queryIsDate _ = False +queryIsDate2 :: Query -> Bool+queryIsDate2 (Date2 _) = True+queryIsDate2 _ = False++queryIsDateOrDate2 :: Query -> Bool+queryIsDateOrDate2 (Date _) = True+queryIsDateOrDate2 (Date2 _) = True+queryIsDateOrDate2 _ = False+ queryIsDesc :: Query -> Bool queryIsDesc (Desc _) = True queryIsDesc _ = False@@ -439,6 +462,15 @@ queryStartDate True (Date2 (DateSpan (Just d) _)) = Just d queryStartDate _ _ = Nothing +-- | What end date (or secondary date) does this query specify, if any ?+-- For OR expressions, use the latest of the dates. NOT is ignored.+queryEndDate :: Bool -> Query -> Maybe Day+queryEndDate secondary (Or ms) = latestMaybeDate' $ map (queryEndDate secondary) ms+queryEndDate secondary (And ms) = earliestMaybeDate' $ map (queryEndDate secondary) ms+queryEndDate False (Date (DateSpan _ (Just d))) = Just d+queryEndDate True (Date2 (DateSpan _ (Just d))) = Just d+queryEndDate _ _ = Nothing+ queryTermDateSpan (Date span) = Just span queryTermDateSpan _ = Nothing @@ -456,14 +488,36 @@ queryDateSpans True (Date2 span) = [span] queryDateSpans _ _ = [] --- | What is the earliest of these dates, where Nothing is earliest ?+-- | What date span (or secondary date span) does this query specify ?+-- For OR expressions, use the widest possible span. NOT is ignored.+queryDateSpan' :: Query -> DateSpan+queryDateSpan' q = spansUnion $ queryDateSpans' q++-- | Extract all date (or secondary date) spans specified in this query.+-- NOT is ignored.+queryDateSpans' :: Query -> [DateSpan]+queryDateSpans' (Or qs) = concatMap queryDateSpans' qs+queryDateSpans' (And qs) = concatMap queryDateSpans' qs+queryDateSpans' (Date span) = [span]+queryDateSpans' (Date2 span) = [span]+queryDateSpans' _ = []++-- | What is the earliest of these dates, where Nothing is latest ? earliestMaybeDate :: [Maybe Day] -> Maybe Day-earliestMaybeDate = headDef Nothing . sortBy compareMaybeDates+earliestMaybeDate mds = head $ sortBy compareMaybeDates mds ++ [Nothing]  -- | What is the latest of these dates, where Nothing is earliest ? latestMaybeDate :: [Maybe Day] -> Maybe Day latestMaybeDate = headDef Nothing . sortBy (flip compareMaybeDates) +-- | What is the earliest of these dates, ignoring Nothings ?+earliestMaybeDate' :: [Maybe Day] -> Maybe Day+earliestMaybeDate' = headDef Nothing . sortBy compareMaybeDates . filter isJust++-- | What is the latest of these dates, ignoring Nothings ?+latestMaybeDate' :: [Maybe Day] -> Maybe Day+latestMaybeDate' = headDef Nothing . sortBy (flip compareMaybeDates) . filter isJust+ -- | Compare two maybe dates, Nothing is earliest. compareMaybeDates :: Maybe Day -> Maybe Day -> Ordering compareMaybeDates Nothing Nothing = EQ@@ -566,12 +620,16 @@  -- | Is this amount's quantity less than, greater than, equal to, or unsignedly equal to this number ? compareAmount :: OrdPlus -> Quantity -> Amount -> Bool-compareAmount ord q Amount{aquantity=aq} = case ord of Lt    -> aq <  q-                                                       Gt    -> aq >  q-                                                       Eq    -> aq == q-                                                       AbsLt -> abs aq <  abs q-                                                       AbsGt -> abs aq >  abs q-                                                       AbsEq -> abs aq == abs q+compareAmount ord q Amount{aquantity=aq} = case ord of Lt      -> aq <  q+                                                       LtEq    -> aq <= q+                                                       Gt      -> aq >  q+                                                       GtEq    -> aq >= q+                                                       Eq      -> aq == q+                                                       AbsLt   -> abs aq <  abs q+                                                       AbsLtEq -> abs aq <= abs q+                                                       AbsGt   -> abs aq >  abs q+                                                       AbsGtEq -> abs aq >= abs q+                                                       AbsEq   -> abs aq == abs q  -- | Does the match expression match this posting ? matchesPosting :: Query -> Posting -> Bool

@@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-| +{-|  This is the entry point to hledger's reading system, which can read Journals from various data formats. Use this module if you want to parse@@ -91,11 +91,11 @@  -- | Read the default journal file specified by the environment, or raise an error. defaultJournal :: IO Journal-defaultJournal = defaultJournalPath >>= readJournalFile Nothing Nothing >>= either error' return+defaultJournal = defaultJournalPath >>= readJournalFile Nothing Nothing True >>= either error' return  -- | Read a journal from the given string, trying all known formats, or simply throw an error. readJournal' :: String -> IO Journal-readJournal' s = readJournal Nothing Nothing Nothing s >>= either error' return+readJournal' s = readJournal Nothing Nothing True Nothing s >>= either error' return  tests_readJournal' = [   "readJournal' parses sample journal" ~: do@@ -114,9 +114,9 @@ -- - otherwise, try them all. -- -- A CSV conversion rules file may also be specified for use by the CSV reader.-readJournal :: Maybe StorageFormat -> Maybe FilePath -> Maybe FilePath -> String -> IO (Either String Journal)-readJournal format rulesfile path s =-  -- trace (show (format, rulesfile, path)) $+-- Also there is a flag specifying whether to check or ignore balance assertions in the journal.+readJournal :: Maybe StorageFormat -> Maybe FilePath -> Bool -> Maybe FilePath -> String -> IO (Either String Journal)+readJournal format rulesfile assrt path s =   tryReaders $ readersFor (format, path, s)   where     -- try each reader in turn, returning the error of the first if all fail@@ -126,8 +126,9 @@         firstSuccessOrBestError :: [String] -> [Reader] -> IO (Either String Journal)         firstSuccessOrBestError [] []        = return $ Left "no readers found"         firstSuccessOrBestError errs (r:rs) = do-          -- printf "trying %s reader\n" (rFormat r)-          result <- (runErrorT . (rParser r) rulesfile path') s+          dbgAtM 1 "trying reader" (rFormat r)+          result <- (runErrorT . (rParser r) rulesfile assrt path') s+          dbgAtM 1 "reader result" $ either id show result           case result of Right j -> return $ Right j                       -- success!                          Left e  -> firstSuccessOrBestError (errs++[e]) rs -- keep trying         firstSuccessOrBestError (e:_) []    = return $ Left e              -- none left, return first error@@ -136,11 +137,11 @@ -- | Which readers are worth trying for this (possibly unspecified) format, filepath, and data ? readersFor :: (Maybe StorageFormat, Maybe FilePath, String) -> [Reader] readersFor (format,path,s) =-    case format of +    dbg ("possible readers for "++show (format,path,elideRight 30 s)) $+    case format of      Just f  -> case readerForStorageFormat f of Just r  -> [r]                                                  Nothing -> []      Nothing -> case path of Nothing  -> readers-                             Just "-" -> readers                              Just p   -> case readersForPathAndData (p,s) of [] -> readers                                                                              rs -> rs @@ -148,7 +149,7 @@ readerForStorageFormat :: StorageFormat -> Maybe Reader readerForStorageFormat s | null rs = Nothing                   | otherwise = Just $ head rs-    where +    where       rs = filter ((s==).rFormat) readers :: [Reader]  -- | Find the readers which think they can handle the given file path and data, if any.@@ -158,16 +159,17 @@ -- | Read a Journal from this file (or stdin if the filename is -) or give -- an error message, using the specified data format or trying all known -- formats. A CSV conversion rules file may be specified for better--- conversion of that format.-readJournalFile :: Maybe StorageFormat -> Maybe FilePath -> FilePath -> IO (Either String Journal)-readJournalFile format rulesfile "-" = do+-- conversion of that format. Also there is a flag specifying whether+-- to check or ignore balance assertions in the journal.+readJournalFile :: Maybe StorageFormat -> Maybe FilePath -> Bool -> FilePath -> IO (Either String Journal)+readJournalFile format rulesfile assrt "-" = do   hSetNewlineMode stdin universalNewlineMode-  getContents >>= readJournal format rulesfile (Just "(stdin)")-readJournalFile format rulesfile f = do+  getContents >>= readJournal format rulesfile assrt (Just "-")+readJournalFile format rulesfile assrt f = do   requireJournalFileExists f   withFile f ReadMode $ \h -> do     hSetNewlineMode h universalNewlineMode-    hGetContents h >>= readJournal format rulesfile (Just f)+    hGetContents h >>= readJournal format rulesfile assrt (Just f)  -- | If the specified journal file does not exist, give a helpful error and quit. requireJournalFileExists :: FilePath -> IO ()@@ -202,6 +204,11 @@  ,"    assets:bank:checking  $1"  ,"    income:salary"  ,""+ ,"comment"+ ,"multi line comment here"+ ,"for testing purposes"+ ,"end comment"+ ,""  ,"2008/06/01 gift"  ,"    assets:bank:checking  $1"  ,"    income:gifts"@@ -228,8 +235,9 @@    tests_Hledger_Read_CsvReader,     "journal" ~: do-    assertBool "journal should parse an empty file" (isRight $ parseWithCtx nullctx JournalReader.journal "")-    jE <- readJournal Nothing Nothing Nothing "" -- don't know how to get it from journal+    r <- runErrorT $ parseWithCtx nullctx JournalReader.journal ""+    assertBool "journal should parse an empty file" (isRight $ r)+    jE <- readJournal Nothing Nothing True Nothing "" -- don't know how to get it from journal     either error' (assertBool "journal parsing an empty file should give an empty journal" . null . jtxns) jE    ]

@@ -3,6 +3,8 @@ A reader for CSV data, using an extra rules file to help interpret the data.  -}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Hledger.Read.CsvReader (   -- * Reader@@ -35,9 +37,9 @@ import System.Locale (defaultTimeLocale) import Test.HUnit import Text.CSV (parseCSV, CSV)-import Text.ParserCombinators.Parsec  hiding (parse)-import Text.ParserCombinators.Parsec.Error-import Text.ParserCombinators.Parsec.Pos+import Text.Parsec hiding (parse)+import Text.Parsec.Pos+import Text.Parsec.Error import Text.Printf (hPrintf,printf)  import Hledger.Data@@ -53,15 +55,16 @@ format :: String format = "csv" --- | Does the given file path and data look like CSV ?+-- | Does the given file path and data look like it might be CSV ? detect :: FilePath -> String -> Bool-detect f _ = takeExtension f == '.':format+detect f s+  | f /= "-"  = takeExtension f == '.':format  -- from a file: yes if the extension is .csv+  | otherwise = length (filter (==',') s) >= 2 -- from stdin: yes if there are two or more commas  -- | Parse and post-process a "Journal" from CSV data, or give an error. -- XXX currently ignores the string and reads from the file path-parse :: Maybe FilePath -> FilePath -> String -> ErrorT String IO Journal-parse rulesfile f s = -- trace ("running "++format++" reader") $- do+parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal+parse rulesfile _ f s = do   r <- liftIO $ readJournalFromCsv rulesfile f s   case r of Left e -> throwError e             Right j -> return j@@ -78,7 +81,7 @@ -- 5. convert the CSV records to a journal using the rules -- @ readJournalFromCsv :: Maybe FilePath -> FilePath -> String -> IO (Either String Journal)-readJournalFromCsv Nothing "-" _ = return $ Left "please use --rules-file when converting stdin"+readJournalFromCsv Nothing "-" _ = return $ Left "please use --rules-file when reading CSV from stdin" readJournalFromCsv mrulesfile csvfile csvdata =  handle (\e -> return $ Left $ show (e :: IOException)) $ do   let throwerr = throw.userError@@ -89,8 +92,11 @@   if created    then hPrintf stderr "creating default conversion rules file %s, edit this file for better results\n" rulesfile    else hPrintf stderr "using conversion rules file %s\n" rulesfile-  rules <- either (throwerr.show) id `fmap` parseRulesFile rulesfile-  return $ dbg "" rules+  rules_ <- liftIO $ runErrorT $ parseRulesFile rulesfile+  let rules = case rules_ of+              Right (t::CsvRules) -> t+              Left err -> throwerr $ show err+  dbgAtM 2 "rules" rules    -- apply skip directive   let skip = maybe 0 oneorerror $ getDirective "skip" rules@@ -99,17 +105,30 @@           oneorerror s  = readDef (throwerr $ "could not parse skip value: " ++ show s) s    -- parse csv-  records <- (either throwerr id . validateCsv skip) `fmap` parseCsv csvfile csvdata-  dbgAtM 1 "" $ take 3 records+  -- parsec seems to fail if you pass it "-" here+  let parsecfilename = if csvfile == "-" then "(stdin)" else csvfile+  records <- (either throwerr id .+              dbgAt 2 "validateCsv" . validateCsv skip .+              dbgAt 2 "parseCsv")+             `fmap` parseCsv parsecfilename csvdata+  dbgAtM 1 "first 3 csv records" $ take 3 records    -- identify header lines   -- let (headerlines, datalines) = identifyHeaderLines records   --     mfieldnames = lastMay headerlines    -- convert to transactions and return as a journal-  let txns = map (transactionFromCsvRecord rules) records-  return $ Right nulljournal{jtxns=sortBy (comparing tdate) txns}+  let txns = snd $ mapAccumL+                     (\pos r -> (pos, transactionFromCsvRecord (incSourceLine pos 1) rules r))+                     (initialPos parsecfilename) records +  -- heuristic: if the records appear to have been in reverse date order,+  -- reverse them all as well as doing a txn date sort,+  -- so that same-day txns' original order is preserved+      txns' | length txns > 1 && tdate (head txns) > tdate (last txns) = reverse txns+            | otherwise = txns+  return $ Right nulljournal{jtxns=sortBy (comparing tdate) txns'}+ parseCsv :: FilePath -> String -> IO (Either ParseError CSV) parseCsv path csvdata =   case path of@@ -173,7 +192,7 @@ newRulesFileContent :: FilePath -> String newRulesFileContent f = unlines   ["# hledger csv conversion rules for " ++ csvFileFor (takeFileName f)-  ,"# cf http://hledger.org/MANUAL.html"+  ,"# cf http://hledger.org/manual#csv-files"   ,""   ,"account1 assets:bank:checking"   ,""@@ -278,10 +297,10 @@ type JournalFieldName = String type FieldTemplate    = String type ConditionalBlock = ([RecordMatcher], [(JournalFieldName, FieldTemplate)]) -- block matches if all RecordMatchers match-type RecordMatcher    = [Regexp] -- match if any regexps match any of the csv fields--- type FieldMatcher     = (CsvFieldName, [Regexp]) -- match if any regexps match this csv field+type RecordMatcher    = [RegexpPattern] -- match if any regexps match any of the csv fields+-- type FieldMatcher     = (CsvFieldName, [RegexpPattern]) -- match if any regexps match this csv field type DateFormat       = String-type Regexp           = String+type RegexpPattern           = String  rules = CsvRules {   rdirectives=[],@@ -316,28 +335,31 @@ getDirective directivename = lookup directivename . rdirectives  -parseRulesFile :: FilePath -> IO (Either ParseError CsvRules)+parseRulesFile :: FilePath -> ErrorT String IO CsvRules parseRulesFile f = do-  s <- readFile' f >>= expandIncludes+  s <- liftIO $ (readFile' f >>= expandIncludes (takeDirectory f))   let rules = parseCsvRules f s-  return $ case rules of-             Left e -> Left e-             Right r -> case validateRules r of-                          Left e -> Left $ toParseError e-                          Right r -> Right r+  case rules of+    Left e -> ErrorT $ return $ Left $ show e+    Right r -> do+               r_ <- liftIO $ runErrorT $ validateRules r+               ErrorT $ case r_ of+                 Left e -> return $ Left $ show $ toParseError e+                 Right r -> return $ Right r   where     toParseError s = newErrorMessage (Message s) (initialPos "")  -- | Pre-parse csv rules to interpolate included files, recursively. -- This is a cheap hack to avoid rewriting the existing parser.-expandIncludes :: String -> IO String-expandIncludes s = do-  let (ls,rest) = break (isPrefixOf "include") $ lines s+expandIncludes :: FilePath -> String -> IO String+expandIncludes basedir content = do+  let (ls,rest) = break (isPrefixOf "include") $ lines content   case rest of     [] -> return $ unlines ls     (('i':'n':'c':'l':'u':'d':'e':f):ls') -> do-      let f' = dropWhile isSpace f-      included <- readFile f' >>= expandIncludes+      let f'       = basedir </> dropWhile isSpace f+          basedir' = takeDirectory f'+      included <- readFile f' >>= expandIncludes basedir'       return $ unlines [unlines ls, included, unlines ls']     ls' -> return $ unlines $ ls ++ ls'   -- should never get here @@ -347,13 +369,13 @@   runParser rulesp rules rulesfile s  -- | Return the validated rules, or an error.-validateRules :: CsvRules -> Either String CsvRules+validateRules :: CsvRules -> ErrorT String IO CsvRules validateRules rules = do-  unless (isAssigned "date")   $ Left "Please specify (at top level) the date field. Eg: date %1\n"+  unless (isAssigned "date")   $ ErrorT $ return $ Left "Please specify (at top level) the date field. Eg: date %1\n"   unless ((amount && not (amountin || amountout)) ||           (not amount && (amountin && amountout)))-    $ Left "Please specify (at top level) either the amount field, or both the amount-in and amount-out fields. Eg: amount %2\n"-  Right rules+    $ ErrorT $ return $ Left "Please specify (at top level) either the amount field, or both the amount-in and amount-out fields. Eg: amount %2\n"+  ErrorT $ return $ Right rules   where     amount = isAssigned "amount"     amountin = isAssigned "amount-in"@@ -362,14 +384,14 @@  -- parsers -rulesp :: GenParser Char CsvRules CsvRules+rulesp :: Stream [Char] m t => ParsecT [Char] CsvRules m CsvRules rulesp = do   many $ choice'     [blankorcommentline                                                    <?> "blank or comment line"-    ,(directive        >>= updateState . addDirective)                     <?> "directive"-    ,(fieldnamelist    >>= updateState . setIndexesAndAssignmentsFromList) <?> "field name list"-    ,(fieldassignment  >>= updateState . addAssignment)                    <?> "field assignment"-    ,(conditionalblock >>= updateState . addConditionalBlock)              <?> "conditional block"+    ,(directive        >>= modifyState . addDirective)                     <?> "directive"+    ,(fieldnamelist    >>= modifyState . setIndexesAndAssignmentsFromList) <?> "field name list"+    ,(fieldassignment  >>= modifyState . addAssignment)                    <?> "field assignment"+    ,(conditionalblock >>= modifyState . addConditionalBlock)              <?> "conditional block"     ]   eof   r <- getState@@ -378,13 +400,21 @@           ,rconditionalblocks=reverse $ rconditionalblocks r           } -blankorcommentline = pdbg 1 "trying blankorcommentline" >> choice' [blankline, commentline]+blankorcommentline :: Stream [Char] m t => ParsecT [Char] CsvRules m ()+blankorcommentline = pdbg 3 "trying blankorcommentline" >> choice' [blankline, commentline]++blankline :: Stream [Char] m t => ParsecT [Char] CsvRules m () blankline = many spacenonewline >> newline >> return () <?> "blank line"++commentline :: Stream [Char] m t => ParsecT [Char] CsvRules m () commentline = many spacenonewline >> commentchar >> restofline >> return () <?> "comment line"++commentchar :: Stream [Char] m t => ParsecT [Char] CsvRules m Char commentchar = oneOf ";#" +directive :: Stream [Char] m t => ParsecT [Char] CsvRules m (DirectiveName, String) directive = do-  pdbg 1 "trying directive"+  pdbg 3 "trying directive"   d <- choice' $ map string directives   v <- (((char ':' >> many spacenonewline) <|> many1 spacenonewline) >> directiveval)        <|> (optional (char ':') >> many spacenonewline >> eolof >> return "")@@ -401,10 +431,12 @@    -- ,"base-currency"   ] +directiveval :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] directiveval = anyChar `manyTill` eolof +fieldnamelist :: Stream [Char] m t => ParsecT [Char] CsvRules m [CsvFieldName] fieldnamelist = (do-  pdbg 1 "trying fieldnamelist"+  pdbg 3 "trying fieldnamelist"   string "fields"   optional $ char ':'   many1 spacenonewline@@ -415,24 +447,29 @@   return $ map (map toLower) $ f:fs   ) <?> "field name list" +fieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] fieldname = quotedfieldname <|> barefieldname +quotedfieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] quotedfieldname = do   char '"'   f <- many1 $ noneOf "\"\n:;#~"   char '"'   return f +barefieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] barefieldname = many1 $ noneOf " \t\n,;#~" +fieldassignment :: Stream [Char] m t => ParsecT [Char] CsvRules m (JournalFieldName, FieldTemplate) fieldassignment = do-  pdbg 1 "trying fieldassignment"+  pdbg 3 "trying fieldassignment"   f <- journalfieldname   assignmentseparator   v <- fieldval   return (f,v)   <?> "field assignment" +journalfieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] journalfieldname = pdbg 2 "trying journalfieldname" >> choice' (map string journalfieldnames)  journalfieldnames =@@ -452,6 +489,7 @@   ,"comment"   ] +assignmentseparator :: Stream [Char] m t => ParsecT [Char] CsvRules m () assignmentseparator = do   pdbg 3 "trying assignmentseparator"   choice [@@ -459,14 +497,17 @@     try (many spacenonewline >> char ':'),     space     ]-  many spacenonewline+  _ <- many spacenonewline+  return () +fieldval :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] fieldval = do   pdbg 2 "trying fieldval"   anyChar `manyTill` eolof +conditionalblock :: Stream [Char] m t => ParsecT [Char] CsvRules m ConditionalBlock conditionalblock = do-  pdbg 1 "trying conditionalblock"+  pdbg 3 "trying conditionalblock"   string "if" >> many spacenonewline >> optional newline   ms <- many1 recordmatcher   as <- many (many1 spacenonewline >> fieldassignment)@@ -475,6 +516,7 @@   return (ms, as)   <?> "conditional block" +recordmatcher :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]] recordmatcher = do   pdbg 2 "trying recordmatcher"   -- pos <- currentPos@@ -485,6 +527,7 @@   return ps   <?> "record matcher" +matchoperator :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] matchoperator = choice' $ map string   ["~"   -- ,"!~"@@ -492,11 +535,13 @@   -- ,"!="   ] +patterns :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]] patterns = do   pdbg 3 "trying patterns"   ps <- many regexp   return ps +regexp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] regexp = do   pdbg 3 "trying regexp"   notFollowedBy matchoperator@@ -524,8 +569,8 @@  -- Convert a CSV record to a transaction using the rules, or raise an -- error if the data can not be parsed.-transactionFromCsvRecord :: CsvRules -> CsvRecord -> Transaction-transactionFromCsvRecord rules record = t+transactionFromCsvRecord :: SourcePos -> CsvRules -> CsvRecord -> Transaction+transactionFromCsvRecord sourcepos rules record = t   where     mdirective       = (`getDirective` rules)     mfieldtemplate   = getEffectiveAssignment rules record@@ -559,7 +604,7 @@     precomment  = maybe "" render $ mfieldtemplate "precomment"     currency    = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency"     amountstr   = (currency++) $ negateIfParenthesised $ getAmountStr rules record-    amount      = either amounterror mixed $ runParser (do {a <- amountp; eof; return a}) nullctx "" amountstr+    amount      = either amounterror (Mixed . (:[])) $ runParser (do {a <- amountp; eof; return a}) nullctx "" amountstr     amounterror err = error' $ unlines       ["error: could not parse \""++amountstr++"\" as an amount"       ,showRecord record@@ -585,6 +630,7 @@      -- build the transaction     t = nulltransaction{+      tsourcepos               = sourcepos,       tdate                    = date',       tdate2                   = mdate2',       tstatus                  = status,@@ -648,8 +694,8 @@                 -- matcherMatches pats = any patternMatches pats                 matcherMatches pats = patternMatches $  "(" ++ intercalate "|" pats ++ ")"                   where-                    patternMatches :: Regexp -> Bool-                    patternMatches pat = regexMatchesCIRegexCompat pat csvline+                    patternMatches :: RegexpPattern -> Bool+                    patternMatches pat = regexMatchesCI pat csvline                       where                         csvline = intercalate "," record 

@@ -1,5 +1,6 @@ -- {-# OPTIONS_GHC -F -pgmF htfpp #-}-{-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds #-}+{-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-} {-|  A reader for hledger's journal file format@@ -58,7 +59,7 @@ import Test.Framework import Text.Parsec.Error #endif-import Text.ParserCombinators.Parsec hiding (parse)+import Text.Parsec hiding (parse) import Text.Printf import System.FilePath import System.Time (getClockTime)@@ -76,83 +77,86 @@ format :: String format = "journal" --- | Does the given file path and data provide hledger's journal file format ?+-- | Does the given file path and data look like it might be hledger's journal format ? detect :: FilePath -> String -> Bool-detect f _ = takeExtension f `elem` ['.':format, ".j"]+detect f s+  | f /= "-"  = takeExtension f `elem` ['.':format, ".j"]  -- from a file: yes if the extension is .journal or .j+  -- from stdin: yes if we can see something that looks like a journal entry (digits in column 0 with the next line indented)+  | otherwise = regexMatches "^[0-9]+.*\n[ \t]+" s  -- | Parse and post-process a "Journal" from hledger's journal file -- format, or give an error.-parse :: Maybe FilePath -> FilePath -> String -> ErrorT String IO Journal-parse _ = -- trace ("running "++format++" reader") .-          parseJournalWith journal+parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal+parse _ = parseJournalWith journal  -- parsing utils  -- | Flatten a list of JournalUpdate's into a single equivalent one. combineJournalUpdates :: [JournalUpdate] -> JournalUpdate-combineJournalUpdates us = liftM (foldl' (.) id) $ sequence us+combineJournalUpdates us = liftM (foldl' (\acc new x -> new (acc x)) id) $ sequence us  -- | Given a JournalUpdate-generating parsec parser, file path and data string, -- parse and post-process a Journal so that it's ready to use, or give an error.-parseJournalWith :: (GenParser Char JournalContext (JournalUpdate,JournalContext)) -> FilePath -> String -> ErrorT String IO Journal-parseJournalWith p f s = do+parseJournalWith :: (ParsecT [Char] JournalContext (ErrorT String IO) (JournalUpdate,JournalContext)) -> Bool -> FilePath -> String -> ErrorT String IO Journal+parseJournalWith p assrt f s = do   tc <- liftIO getClockTime   tl <- liftIO getCurrentLocalTime   y <- liftIO getCurrentYear-  case runParser p nullctx{ctxYear=Just y} f s of+  r <- runParserT p nullctx{ctxYear=Just y} f s+  case r of     Right (updates,ctx) -> do                            j <- updates `ap` return nulljournal-                           case journalFinalise tc tl f s ctx j of+                           case journalFinalise tc tl f s ctx assrt j of                              Right j'  -> return j'                              Left estr -> throwError estr     Left e -> throwError $ show e -setYear :: Integer -> GenParser tok JournalContext ()-setYear y = updateState (\ctx -> ctx{ctxYear=Just y})+setYear :: Stream [Char] m Char => Integer -> ParsecT [Char] JournalContext m ()+setYear y = modifyState (\ctx -> ctx{ctxYear=Just y}) -getYear :: GenParser tok JournalContext (Maybe Integer)+getYear :: Stream [Char] m Char => ParsecT s JournalContext m (Maybe Integer) getYear = liftM ctxYear getState -setCommodityAndStyle :: (Commodity,AmountStyle) -> GenParser tok JournalContext ()-setCommodityAndStyle cs = updateState (\ctx -> ctx{ctxCommodityAndStyle=Just cs})+setDefaultCommodityAndStyle :: Stream [Char] m Char => (Commodity,AmountStyle) -> ParsecT [Char] JournalContext m ()+setDefaultCommodityAndStyle cs = modifyState (\ctx -> ctx{ctxDefaultCommodityAndStyle=Just cs}) -getCommodityAndStyle :: GenParser tok JournalContext (Maybe (Commodity,AmountStyle))-getCommodityAndStyle = ctxCommodityAndStyle `fmap` getState+getDefaultCommodityAndStyle :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe (Commodity,AmountStyle))+getDefaultCommodityAndStyle = ctxDefaultCommodityAndStyle `fmap` getState -pushParentAccount :: String -> GenParser tok JournalContext ()-pushParentAccount parent = updateState addParentAccount+pushParentAccount :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m ()+pushParentAccount parent = modifyState addParentAccount     where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 } -popParentAccount :: GenParser tok JournalContext ()+popParentAccount :: Stream [Char] m Char => ParsecT [Char] JournalContext m () popParentAccount = do ctx0 <- getState                       case ctxAccount ctx0 of                         [] -> unexpected "End of account block with no beginning"                         (_:rest) -> setState $ ctx0 { ctxAccount = rest } -getParentAccount :: GenParser tok JournalContext String+getParentAccount :: Stream [Char] m Char => ParsecT [Char] JournalContext m String getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState -addAccountAlias :: (AccountName,AccountName) -> GenParser tok JournalContext ()-addAccountAlias a = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})+addAccountAlias :: Stream [Char] m Char => AccountAlias -> ParsecT [Char] JournalContext m ()+addAccountAlias a = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases}) -getAccountAliases :: GenParser tok JournalContext [(AccountName,AccountName)]+getAccountAliases :: Stream [Char] m Char => ParsecT [Char] JournalContext m [AccountAlias] getAccountAliases = liftM ctxAliases getState -clearAccountAliases :: GenParser tok JournalContext ()-clearAccountAliases = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})+clearAccountAliases :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()+clearAccountAliases = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})  -- parsers  -- | Top-level journal parser. Returns a single composite, I/O performing, -- error-raising "JournalUpdate" (and final "JournalContext") which can be -- applied to an empty journal to get the final result.-journal :: GenParser Char JournalContext (JournalUpdate,JournalContext)+journal :: ParsecT [Char] JournalContext (ErrorT String IO) (JournalUpdate,JournalContext) journal = do   journalupdates <- many journalItem   eof   finalctx <- getState   return $ (combineJournalUpdates journalupdates, finalctx)-    where +    where       -- 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@@ -162,10 +166,11 @@                            , liftM (return . addPeriodicTransaction) periodictransaction                            , liftM (return . addHistoricalPrice) historicalpricedirective                            , emptyorcommentlinep >> return (return id)+                           , multilinecommentp >> return (return id)                            ] <?> "journal transaction or directive"  -- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives-directive :: GenParser Char JournalContext JournalUpdate+directive :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate directive = do   optional $ char '!'   choice' [@@ -183,7 +188,7 @@    ]   <?> "directive" -includedirective :: GenParser Char JournalContext JournalUpdate+includedirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate includedirective = do   string "include"   many1 spacenonewline@@ -191,36 +196,48 @@   outerState <- getState   outerPos <- getPosition   let curdir = takeDirectory (sourceName outerPos)-  return $ do filepath <- expandPath curdir filename-              txt <- readFileOrError outerPos filepath-              let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"-              case runParser journal outerState filepath txt of-                Right (ju,_) -> combineJournalUpdates [return $ journalAddFile (filepath,txt), ju] `catchError` (throwError . (inIncluded ++))-                Left err     -> throwError $ inIncluded ++ show err-      where readFileOrError pos fp =+  let (u::ErrorT String IO (Journal -> Journal, JournalContext)) = do+       filepath <- expandPath curdir filename+       txt <- readFileOrError outerPos filepath+       let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"+       r <- runParserT journal outerState filepath txt+       case r of+         Right (ju, ctx) -> do+                            u <- combineJournalUpdates [ return $ journalAddFile (filepath,txt)+                                                       , ju+                                                       ] `catchError` (throwError . (inIncluded ++))+                            return (u, ctx)+         Left err -> throwError $ inIncluded ++ show err+       where readFileOrError pos fp =                 ErrorT $ liftM Right (readFile' fp) `C.catch`                   \e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException))+  r <- liftIO $ runErrorT u+  case r of+    Left err -> return $ throwError err+    Right (ju, ctx) -> return $ ErrorT $ return $ Right ju  journalAddFile :: (FilePath,String) -> Journal -> Journal journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}-  -- XXX currently called in reverse order of includes, I can't see why+ -- NOTE: first encountered file to left, to avoid a reverse -accountdirective :: GenParser Char JournalContext JournalUpdate+accountdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate accountdirective = do   string "account"   many1 spacenonewline   parent <- accountnamep   newline   pushParentAccount parent-  return $ return id+  -- return $ return id+  return $ ErrorT $ return $ Right id -enddirective :: GenParser Char JournalContext JournalUpdate+enddirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate enddirective = do   string "end"   popParentAccount-  return (return id)+  -- return (return id)+  return $ ErrorT $ return $ Right id -aliasdirective :: GenParser Char JournalContext JournalUpdate+aliasdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate aliasdirective = do   string "alias"   many1 spacenonewline@@ -231,13 +248,13 @@                   ,accountNameWithoutPostingType $ strip alias)   return $ return id -endaliasesdirective :: GenParser Char JournalContext JournalUpdate+endaliasesdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate endaliasesdirective = do   string "end aliases"   clearAccountAliases   return (return id) -tagdirective :: GenParser Char JournalContext JournalUpdate+tagdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate tagdirective = do   string "tag" <?> "tag directive"   many1 spacenonewline@@ -245,13 +262,13 @@   restofline   return $ return id -endtagdirective :: GenParser Char JournalContext JournalUpdate+endtagdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate endtagdirective = do   (string "end tag" <|> string "pop") <?> "end tag or pop directive"   restofline   return $ return id -defaultyeardirective :: GenParser Char JournalContext JournalUpdate+defaultyeardirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate defaultyeardirective = do   char 'Y' <?> "default year"   many spacenonewline@@ -261,20 +278,20 @@   setYear y'   return $ return id -defaultcommoditydirective :: GenParser Char JournalContext JournalUpdate+defaultcommoditydirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate defaultcommoditydirective = do   char 'D' <?> "default commodity"   many1 spacenonewline   Amount{..} <- amountp-  setCommodityAndStyle (acommodity, astyle)+  setDefaultCommodityAndStyle (acommodity, astyle)   restofline   return $ return id -historicalpricedirective :: GenParser Char JournalContext HistoricalPrice+historicalpricedirective :: ParsecT [Char] JournalContext (ErrorT String IO) HistoricalPrice historicalpricedirective = do   char 'P' <?> "historical price"   many spacenonewline-  date <- try (do {LocalTime d _ <- datetimep; return d}) <|> date -- a time is ignored+  date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored   many1 spacenonewline   symbol <- commoditysymbol   many spacenonewline@@ -282,7 +299,7 @@   restofline   return $ HistoricalPrice date symbol price -ignoredpricecommoditydirective :: GenParser Char JournalContext JournalUpdate+ignoredpricecommoditydirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate ignoredpricecommoditydirective = do   char 'N' <?> "ignored-price commodity"   many1 spacenonewline@@ -290,7 +307,7 @@   restofline   return $ return id -commodityconversiondirective :: GenParser Char JournalContext JournalUpdate+commodityconversiondirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate commodityconversiondirective = do   char 'C' <?> "commodity conversion"   many1 spacenonewline@@ -302,7 +319,7 @@   restofline   return $ return id -modifiertransaction :: GenParser Char JournalContext ModifierTransaction+modifiertransaction :: ParsecT [Char] JournalContext (ErrorT String IO) ModifierTransaction modifiertransaction = do   char '=' <?> "modifier transaction"   many spacenonewline@@ -310,7 +327,7 @@   postings <- postings   return $ ModifierTransaction valueexpr postings -periodictransaction :: GenParser Char JournalContext PeriodicTransaction+periodictransaction :: ParsecT [Char] JournalContext (ErrorT String IO) PeriodicTransaction periodictransaction = do   char '~' <?> "periodic transaction"   many spacenonewline@@ -319,18 +336,20 @@   return $ PeriodicTransaction periodexpr postings  -- | Parse a (possibly unbalanced) transaction.-transaction :: GenParser Char JournalContext Transaction+transaction :: ParsecT [Char] JournalContext (ErrorT String IO) Transaction transaction = do   -- ptrace "transaction"-  date <- date <?> "transaction"-  edate <- optionMaybe (secondarydate date) <?> "secondary date"+  sourcepos <- getPosition+  date <- datep <?> "transaction"+  edate <- optionMaybe (secondarydatep date) <?> "secondary date"+  lookAhead (spacenonewline <|> newline) <?> "whitespace or newline"   status <- status <?> "cleared flag"   code <- codep <?> "transaction code"   description <- descriptionp >>= return . strip   comment <- try followingcommentp <|> (newline >> return "")   let tags = tagsInComment comment   postings <- postings-  return $ txnTieKnot $ Transaction date edate status code description comment tags postings ""+  return $ txnTieKnot $ Transaction sourcepos date edate status code description comment tags postings ""  descriptionp = many (noneOf ";\n") @@ -350,7 +369,7 @@                         assertEqual (ttags t) (ttags t2)                         assertEqual (tpreceding_comment_lines t) (tpreceding_comment_lines t2)                         assertEqual (show $ tpostings t) (show $ tpostings t2)-    -- "0000/01/01\n\n" `gives` nulltransaction +    -- "0000/01/01\n\n" `gives` nulltransaction     unlines [       "2012/05/14=2012/05/15 (code) desc  ; tcomment1",       "    ; tcomment2",@@ -408,7 +427,7 @@         ,"  b"         ," "         ]-                    +     let p = parseWithCtx nullctx transaction $ unlines              ["2009/1/1 x  ; transaction comment"              ," a  1  ; posting 1 comment"@@ -418,16 +437,18 @@              ]     assertRight p     assertEqual 2 (let Right t = p in length $ tpostings t)-#endif       +#endif  -- | 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.-date :: GenParser Char JournalContext Day-date = do+datep :: Stream [Char] m t => ParsecT [Char] JournalContext m Day+datep = do   -- hacky: try to ensure precise errors for invalid dates   -- XXX reported error position is not too good   -- pos <- getPosition   datestr <- many1 $ choice' [digit, datesepchar]+  let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr+  when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr   let dateparts = wordsBy (`elem` datesepchars) datestr   currentyear <- getYear   [y,m,d] <- case (dateparts,currentyear) of@@ -445,9 +466,9 @@ -- 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.-datetimep :: GenParser Char JournalContext LocalTime+datetimep :: Stream [Char] m Char => ParsecT [Char] JournalContext m LocalTime datetimep = do-  day <- date+  day <- datep   many1 spacenonewline   h <- many1 digit   let h' = read h@@ -473,8 +494,8 @@   -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')   return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') -secondarydate :: Day -> GenParser Char JournalContext Day-secondarydate primarydate = do+secondarydatep :: Stream [Char] m Char => Day -> ParsecT [Char] JournalContext m Day+secondarydatep primarydate = do   char '='   -- kludgy way to use primary date for default year   let withDefaultYear d p = do@@ -483,27 +504,27 @@         r <- p         when (isJust y) $ setYear $ fromJust y         return r-  edate <- withDefaultYear primarydate date+  edate <- withDefaultYear primarydate datep   return edate -status :: GenParser Char JournalContext Bool+status :: Stream [Char] m Char => ParsecT [Char] JournalContext m Bool status = try (do { many spacenonewline; (char '*' <|> char '!') <?> "status"; return True } ) <|> return False -codep :: GenParser Char JournalContext String+codep :: Stream [Char] m Char => ParsecT [Char] JournalContext m String codep = try (do { many1 spacenonewline; char '(' <?> "codep"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""  -- Parse the following whitespace-beginning lines as postings, posting tags, and/or comments.-postings :: GenParser Char JournalContext [Posting]+postings :: Stream [Char] m Char => ParsecT [Char] JournalContext m [Posting] postings = many1 (try postingp) <?> "postings"-            --- linebeginningwithspaces :: GenParser Char JournalContext String++-- linebeginningwithspaces :: Stream [Char] m Char => ParsecT [Char] JournalContext m String -- linebeginningwithspaces = do --   sp <- many1 spacenonewline --   c <- nonspace --   cs <- restofline --   return $ sp ++ (c:cs) ++ "\n" -postingp :: GenParser Char JournalContext Posting+postingp :: Stream [Char] m Char => ParsecT [Char] JournalContext m Posting postingp = do   many1 spacenonewline   status <- status@@ -511,22 +532,40 @@   account <- modifiedaccountname   let (ptype, account') = (accountNamePostingType account, unbracket account)   amount <- spaceandamountormissing-  massertion <- balanceassertion+  massertion <- partialbalanceassertion   _ <- fixedlotprice   many spacenonewline   ctx <- getState   comment <- try followingcommentp <|> (newline >> return "")   let tags = tagsInComment comment   -- oh boy-  d  <- maybe (return Nothing) (either (fail.show) (return.Just)) (parseWithCtx ctx date `fmap` dateValueFromTags tags)-  d2 <- maybe (return Nothing) (either (fail.show) (return.Just)) (parseWithCtx ctx date `fmap` date2ValueFromTags tags)-  return posting{pdate=d, pdate2=d2, pstatus=status, paccount=account', pamount=amount, pcomment=comment, ptype=ptype, ptags=tags, pbalanceassertion=massertion}+  date <- case dateValueFromTags tags of+        Nothing -> return Nothing+        Just v -> case runParser datep ctx "" v of+                    Right d -> return $ Just d+                    Left err -> parserFail $ show err+  date2 <- case date2ValueFromTags tags of+        Nothing -> return Nothing+        Just v -> case runParser datep ctx "" v of+                    Right d -> return $ Just d+                    Left err -> parserFail $ show err+  return posting+   { pdate=date+   , pdate2=date2+   , pstatus=status+   , paccount=account'+   , pamount=amount+   , pcomment=comment+   , ptype=ptype+   , ptags=tags+   , pbalanceassertion=massertion+   }  #ifdef TESTS test_postingp = do     let s `gives` ep = do                          let parse = parseWithCtx nullctx postingp s-                         assertBool -- "postingp parser" +                         assertBool -- "postingp parser"                            $ isRight parse                          let Right ap = parse                              same f = assertEqual (f ep) (f ap)@@ -541,21 +580,21 @@     "  expenses:food:dining  $10.00   ; a: a a \n   ; b: b b \n" `gives`       posting{paccount="expenses:food:dining", pamount=Mixed [usd 10], pcomment=" a: a a \n b: b b \n", ptags=[("a","a a"), ("b","b b")]} -    " a  1 ; [2012/11/28]\n" `gives` +    " a  1 ; [2012/11/28]\n" `gives`       ("a" `post` num 1){pcomment=" [2012/11/28]\n"                         ,ptags=[("date","2012/11/28")]                         ,pdate=parsedateM "2012/11/28"} -    " a  1 ; a:a, [=2012/11/28]\n" `gives` +    " a  1 ; a:a, [=2012/11/28]\n" `gives`       ("a" `post` num 1){pcomment=" a:a, [=2012/11/28]\n"                         ,ptags=[("a","a"), ("date2","2012/11/28")]                         ,pdate=Nothing} -    " a  1 ; a:a\n  ; [2012/11/28=2012/11/29],b:b\n" `gives` +    " a  1 ; a:a\n  ; [2012/11/28=2012/11/29],b:b\n" `gives`       ("a" `post` num 1){pcomment=" a:a\n [2012/11/28=2012/11/29],b:b\n"                         ,ptags=[("a","a"), ("date","2012/11/28"), ("date2","2012/11/29"), ("b","b")]                         ,pdate=parsedateM "2012/11/28"}-     +     assertBool -- "postingp parses a quoted commodity with numbers"       (isRight $ parseWithCtx nullctx postingp "  a  1 \"DE123\"\n") @@ -567,10 +606,10 @@     -- let Right p = parse     -- assertEqual "next-line comment\n" (pcomment p)     -- assertEqual (Just nullmixedamt) (pbalanceassertion p)-#endif       +#endif  -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.-modifiedaccountname :: GenParser Char JournalContext AccountName+modifiedaccountname :: Stream [Char] m Char => ParsecT [Char] JournalContext m AccountName modifiedaccountname = do   a <- accountnamep   prefix <- getParentAccount@@ -582,14 +621,14 @@ -- them, and are terminated by two or more spaces. They should have one or -- more components of at least one character, separated by the account -- separator char.-accountnamep :: GenParser Char st AccountName+accountnamep :: Stream [Char] m Char => ParsecT [Char] st m AccountName accountnamep = do     a <- many1 (nonspace <|> singlespace)     let a' = striptrailingspace a     when (accountNameFromComponents (accountNameComponents a') /= a')          (fail $ "account name seems ill-formed: "++a')     return a'-    where +    where       singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})       -- couldn't avoid consuming a final space sometimes, harmless       striptrailingspace s = if last s == ' ' then init s else s@@ -600,7 +639,7 @@ -- | Parse whitespace then an amount, with an optional left or right -- currency symbol and optional price, or return the special -- "missing" marker amount.-spaceandamountormissing :: GenParser Char JournalContext MixedAmount+spaceandamountormissing :: Stream [Char] m Char => ParsecT [Char] JournalContext m MixedAmount spaceandamountormissing =   try (do         many1 spacenonewline@@ -619,12 +658,12 @@     assertParseEqual' (parseWithCtx nullctx spaceandamountormissing "$47.18") missingmixedamt     assertParseEqual' (parseWithCtx nullctx spaceandamountormissing " ") missingmixedamt     assertParseEqual' (parseWithCtx nullctx spaceandamountormissing "") missingmixedamt-#endif       +#endif  -- | Parse a single-commodity amount, with optional symbol on the left or -- right, optional unit or total price, and optional (ignored) -- ledger-style balance assertion or fixed lot price declaration.-amountp :: GenParser Char JournalContext Amount+amountp :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount amountp = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount  #ifdef TESTS@@ -639,69 +678,73 @@     assertParseEqual'      (parseWithCtx nullctx amountp "$10 @@ €5")      (usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0))-#endif       +#endif  -- | Parse an amount from a string, or get an error. amountp' :: String -> Amount-amountp' s = either (error' . show) id $ parseWithCtx nullctx amountp s+amountp' s =+  case runParser amountp nullctx "" s of+    Right t -> t+    Left err -> error' $ show err  -- | Parse a mixed amount from a string, or get an error. mamountp' :: String -> MixedAmount-mamountp' = mixed . amountp'+mamountp' = Mixed . (:[]) . amountp' -signp :: GenParser Char JournalContext String+signp :: Stream [Char] m t => ParsecT [Char] JournalContext m String signp = do   sign <- optionMaybe $ oneOf "+-"   return $ case sign of Just '-' -> "-"                         _        -> "" -leftsymbolamount :: GenParser Char JournalContext Amount+leftsymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount leftsymbolamount = do   sign <- signp-  c <- commoditysymbol +  c <- commoditysymbol   sp <- many spacenonewline-  (q,prec,dec,sep,seppos) <- numberp-  let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos}+  (q,prec,mdec,mgrps) <- numberp+  let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}   p <- priceamount   let applysign = if sign=="-" then negate else id   return $ applysign $ Amount c q p s   <?> "left-symbol amount" -rightsymbolamount :: GenParser Char JournalContext Amount+rightsymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount rightsymbolamount = do-  (q,prec,dec,sep,seppos) <- numberp+  (q,prec,mdec,mgrps) <- numberp   sp <- many spacenonewline   c <- commoditysymbol   p <- priceamount-  let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos}+  let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}   return $ Amount c q p s   <?> "right-symbol amount" -nosymbolamount :: GenParser Char JournalContext Amount+nosymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount nosymbolamount = do-  (q,prec,dec,sep,seppos) <- numberp+  (q,prec,mdec,mgrps) <- numberp   p <- priceamount-  defcs <- getCommodityAndStyle+  -- apply the most recently seen default commodity and style to this commodityless amount+  defcs <- getDefaultCommodityAndStyle   let (c,s) = case defcs of         Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) prec})-        Nothing          -> ("", amountstyle{asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos})+        Nothing          -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps})   return $ Amount c q p s   <?> "no-symbol amount" -commoditysymbol :: GenParser Char JournalContext String+commoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) <?> "commodity symbol" -quotedcommoditysymbol :: GenParser Char JournalContext String+quotedcommoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String quotedcommoditysymbol = do   char '"'   s <- many1 $ noneOf ";\n\""   char '"'   return s -simplecommoditysymbol :: GenParser Char JournalContext String+simplecommoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars) -priceamount :: GenParser Char JournalContext Price+priceamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Price priceamount =     try (do           many spacenonewline@@ -717,8 +760,8 @@             return $ UnitPrice a))          <|> return NoPrice -balanceassertion :: GenParser Char JournalContext (Maybe MixedAmount)-balanceassertion =+partialbalanceassertion :: Stream [Char] m t => ParsecT [Char] JournalContext m (Maybe MixedAmount)+partialbalanceassertion =     try (do           many spacenonewline           char '='@@ -727,8 +770,18 @@           return $ Just $ Mixed [a])          <|> return Nothing +-- balanceassertion :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe MixedAmount)+-- balanceassertion =+--     try (do+--           many spacenonewline+--           string "=="+--           many spacenonewline+--           a <- amountp -- XXX should restrict to a simple amount+--           return $ Just $ Mixed [a])+--          <|> return Nothing+ -- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices-fixedlotprice :: GenParser Char JournalContext (Maybe Amount)+fixedlotprice :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe Amount) fixedlotprice =     try (do           many spacenonewline@@ -742,59 +795,72 @@           return $ Just a)          <|> return Nothing --- | Parse a numeric quantity for its value and display attributes.  Some--- international number formats (cf--- http://en.wikipedia.org/wiki/Decimal_separator) are accepted: either--- period or comma may be used for the decimal point, and the other of--- these may be used for separating digit groups in the integer part (eg a--- thousands separator).  This returns the numeric value, the precision--- (number of digits to the right of the decimal point), the decimal point--- and separator characters (defaulting to . and ,), and the positions of--- separators (counting leftward from the decimal point, the last is--- assumed to repeat).-numberp :: GenParser Char JournalContext (Quantity, Int, Char, Char, [Int])+-- | Parse a string representation of a number for its value and display+-- attributes.+--+-- Some international number formats are accepted, eg either period or comma+-- may be used for the decimal point, and the other of these may be used for+-- separating digit groups in the integer part. See+-- http://en.wikipedia.org/wiki/Decimal_separator for more examples.+--+-- This returns: the parsed numeric value, the precision (number of digits+-- seen following the decimal point), the decimal point character used if any,+-- and the digit group style if any.+--+numberp :: Stream [Char] m t => ParsecT [Char] JournalContext m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle) numberp = do+  -- a number is an optional sign followed by a sequence of digits possibly+  -- interspersed with periods, commas, or both+  -- ptrace "numberp"   sign <- signp   parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.']-  let numeric = isNumber . headDef '_'-      (numparts, puncparts) = partition numeric parts-      (ok,decimalpoint',separator') =-          case (numparts,puncparts) of-            ([],_)     -> (False, Nothing, Nothing)  -- no digits-            (_,[])     -> (True, Nothing, Nothing)  -- no punctuation chars-            (_,[d:""]) -> (True, Just d, Nothing)   -- just one punctuation char, assume it's a decimal point-            (_,[_])    -> (False, Nothing, Nothing) -- adjacent punctuation chars, not ok-            (_,_:_:_)  -> let (s:ss, d) = (init puncparts, last puncparts) -- two or more punctuation chars-                          in if (any ((/=1).length) puncparts  -- adjacent punctuation chars, not ok-                                 || any (s/=) ss                -- separator chars differ, not ok-                                 || head parts == s)            -- number begins with a separator char, not ok-                              then (False, Nothing, Nothing)-                              else if s == d-                                    then (True, Nothing, Just $ head s) -- just one kind of punctuation, assume separator chars-                                    else (True, Just $ head d, Just $ head s) -- separators and a decimal point+  dbgAt 8 "numberp parsed" (sign,parts) `seq` return ()++  -- check the number is well-formed and identify the decimal point and digit+  -- group separator characters used, if any+  let (numparts, puncparts) = partition numeric parts+      (ok, mdecimalpoint, mseparator) =+          case (numparts, puncparts) of+            ([],_)     -> (False, Nothing, Nothing)  -- no digits, not ok+            (_,[])     -> (True, Nothing, Nothing)   -- digits with no punctuation, ok+            (_,[[d]])  -> (True, Just d, Nothing)    -- just a single punctuation of length 1, assume it's a decimal point+            (_,[_])    -> (False, Nothing, Nothing)  -- a single punctuation of some other length, not ok+            (_,_:_:_)  ->                                       -- two or more punctuations+              let (s:ss, d) = (init puncparts, last puncparts)  -- the leftmost is a separator and the rightmost may be a decimal point+              in if (any ((/=1).length) puncparts               -- adjacent punctuation chars, not ok+                     || any (s/=) ss                            -- separator chars vary, not ok+                     || head parts == s)                        -- number begins with a separator char, not ok+                 then (False, Nothing, Nothing)+                 else if s == d+                      then (True, Nothing, Just $ head s)       -- just one kind of punctuation - must be separators+                      else (True, Just $ head d, Just $ head s) -- separator(s) and a decimal point   when (not ok) (fail $ "number seems ill-formed: "++concat parts)-  let (intparts',fracparts') = span ((/= decimalpoint') . Just . head) parts++  -- get the digit group sizes and digit group style if any+  let (intparts',fracparts') = span ((/= mdecimalpoint) . Just . head) parts       (intparts, fracpart) = (filter numeric intparts', filter numeric fracparts')-      separatorpositions = reverse $ map length $ drop 1 intparts-      int = concat $ "":intparts+      groupsizes = reverse $ case map length intparts of+                               (a:b:cs) | a < b -> b:cs+                               gs               -> gs+      mgrps = maybe Nothing (Just . (`DigitGroups` groupsizes)) $ mseparator++  -- put the parts back together without digit group separators, get the precision and parse the value+  let int = concat $ "":intparts       frac = concat $ "":fracpart       precision = length frac       int' = if null int then "0" else int       frac' = if null frac then "0" else frac       quantity = read $ sign++int'++"."++frac' -- this read should never fail-      (decimalpoint, separator) = case (decimalpoint', separator') of (Just d,  Just s)   -> (d,s)-                                                                      (Just '.',Nothing)  -> ('.',',')-                                                                      (Just ',',Nothing)  -> (',','.')-                                                                      (Nothing, Just '.') -> (',','.')-                                                                      (Nothing, Just ',') -> ('.',',')-                                                                      _                   -> ('.',',')-  return (quantity,precision,decimalpoint,separator,separatorpositions)++  return $ dbgAt 8 "numberp quantity,precision,mdecimalpoint,mgrps" (quantity,precision,mdecimalpoint,mgrps)   <?> "numberp"+  where+    numeric = isNumber . headDef '_'  #ifdef TESTS test_numberp = do       let s `is` n = assertParseEqual' (parseWithCtx nullctx numberp s) n-          assertFails = assertBool . isLeft . parseWithCtx nullctx numberp +          assertFails = assertBool . isLeft . parseWithCtx nullctx numberp       assertFails ""       "0"          `is` (0, 0, '.', ',', [])       "1"          `is` (1, 0, '.', ',', [])@@ -813,29 +879,38 @@       assertFails "1..1"       assertFails ".1,"       assertFails ",1."-#endif       +#endif  -- comment parsers -emptyorcommentlinep :: GenParser Char JournalContext ()+multilinecommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m ()+multilinecommentp = do+  string "comment" >> newline+  go+  where+    go = try (string "end comment" >> newline >> return ())+         <|> (anyLine >> go)+    anyLine = anyChar `manyTill` newline++emptyorcommentlinep :: Stream [Char] m Char => ParsecT [Char] JournalContext m () emptyorcommentlinep = do   many spacenonewline >> (comment <|> (many spacenonewline >> newline >> return ""))   return () -followingcommentp :: GenParser Char JournalContext String+followingcommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String followingcommentp =   -- ptrace "followingcommentp"   do samelinecomment <- many spacenonewline >> (try semicoloncomment <|> (newline >> return ""))      newlinecomments <- many (try (many1 spacenonewline >> semicoloncomment))      return $ unlines $ samelinecomment:newlinecomments -comment :: GenParser Char JournalContext String+comment :: Stream [Char] m Char => ParsecT [Char] JournalContext m String comment = commentStartingWith "#;" -semicoloncomment :: GenParser Char JournalContext String+semicoloncomment :: Stream [Char] m Char => ParsecT [Char] JournalContext m String semicoloncomment = commentStartingWith ";" -commentStartingWith :: String -> GenParser Char JournalContext String+commentStartingWith :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m String commentStartingWith cs = do   -- ptrace "commentStartingWith"   oneOf cs@@ -848,11 +923,11 @@ tagsInComment c = concatMap tagsInCommentLine $ lines c'   where     c' = ledgerDateSyntaxToTags c-    + tagsInCommentLine :: String -> [Tag] tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ','   where-    maybetag s = case parseWithCtx nullctx tag s of+    maybetag s = case runParser tag nullctx "" s of                   Right t -> Just t                   Left _ -> Nothing @@ -883,7 +958,7 @@     replace' ('=':s) | isdate s = date2tag s     replace' s | last s =='=' && isdate (init s) = datetag (init s)     replace' s | length ds == 2 && isdate d1 && isdate d1 = datetag d1 ++ date2tag d2-      where +      where         ds = splitAtElement '=' s         d1 = headDef "" ds         d2 = lastDef "" ds@@ -892,17 +967,17 @@     isdate = isJust . parsedateM     datetag s = "date:"++s++", "     date2tag s = "date2:"++s++", "-    + #ifdef TESTS test_ledgerDateSyntaxToTags = do      assertEqual "date2:2012/11/28, " $ ledgerDateSyntaxToTags "[=2012/11/28]"-#endif       -  +#endif+ dateValueFromTags, date2ValueFromTags :: [Tag] -> Maybe String dateValueFromTags  ts = maybe Nothing (Just . snd) $ find ((=="date") . fst) ts date2ValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date2") . fst) ts -    + {- old hunit tests  test_Hledger_Read_JournalReader = TestList $ concat [@@ -932,10 +1007,10 @@      assertParse (parseWithCtx nullctx comment " \t; x\n")      assertParse (parseWithCtx nullctx comment "#x") -  ,"date" ~: do-     assertParse (parseWithCtx nullctx date "2011/1/1")-     assertParseFailure (parseWithCtx nullctx date "1/1")-     assertParse (parseWithCtx nullctx{ctxYear=Just 2011} date "1/1")+  ,"datep" ~: do+     assertParse (parseWithCtx nullctx datep "2011/1/1")+     assertParseFailure (parseWithCtx nullctx datep "1/1")+     assertParse (parseWithCtx nullctx{ctxYear=Just 2011} datep "1/1")    ,"datetimep" ~: do       let p = do {t <- datetimep; eof; return t}

@@ -49,8 +49,9 @@ where import Control.Monad import Control.Monad.Error+import Data.List (isPrefixOf, foldl') import Test.HUnit-import Text.ParserCombinators.Parsec hiding (parse)+import Text.Parsec hiding (parse) import System.FilePath  import Hledger.Data@@ -68,23 +69,24 @@ format :: String format = "timelog" --- | Does the given file path and data provide timeclock.el's timelog format ?+-- | Does the given file path and data look like it might be timeclock.el's timelog format ? detect :: FilePath -> String -> Bool-detect f _ = takeExtension f == '.':format+detect f s+  | f /= "-"  = takeExtension f == '.':format               -- from a file: yes if the extension is .timelog+  | otherwise = "i " `isPrefixOf` s || "o " `isPrefixOf` s  -- from stdin: yes if it starts with "i " or "o "  -- | Parse and post-process a "Journal" from timeclock.el's timelog -- format, saving the provided file path and the current time, or give an -- error.-parse :: Maybe FilePath -> FilePath -> String -> ErrorT String IO Journal-parse _ = -- trace ("running "++format++" reader") .-          parseJournalWith timelogFile+parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal+parse _ = parseJournalWith timelogFile -timelogFile :: GenParser Char JournalContext (JournalUpdate,JournalContext)+timelogFile :: ParsecT [Char] JournalContext (ErrorT String IO) (JournalUpdate, JournalContext) timelogFile = do items <- many timelogItem                  eof                  ctx <- getState-                 return (liftM (foldr (.) id) $ sequence items, ctx)-    where +                 return (liftM (foldl' (\acc new x -> new (acc x)) id) $ sequence items, ctx)+    where       -- As all ledger line types can be distinguished by the first       -- character, excepting transactions versus empty (blank or       -- comment-only) lines, can use choice w/o try@@ -96,13 +98,14 @@                           ] <?> "timelog entry, or default year or historical price directive"  -- | Parse a timelog entry.-timelogentry :: GenParser Char JournalContext TimeLogEntry+timelogentry :: ParsecT [Char] JournalContext (ErrorT String IO) TimeLogEntry timelogentry = do+  sourcepos <- getPosition   code <- oneOf "bhioO"   many1 spacenonewline   datetime <- datetimep   comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline)-  return $ TimeLogEntry (read [code]) datetime (maybe "" rstrip comment)+  return $ TimeLogEntry sourcepos (read [code]) datetime (maybe "" rstrip comment)  tests_Hledger_Read_TimelogReader = TestList [  ]

@@ -39,9 +39,9 @@ -- It has: -- -- * The full account name--- +-- -- * The ledger-style short elided account name (the leaf name, prefixed by any boring parents immediately above)--- +-- -- * The number of indentation steps to use when rendering a ledger-style account tree --   (normally the 0-based depth of this account excluding boring parents, or 0 with --flat). type RenderableAccountName = (AccountName, AccountName, Int)@@ -67,15 +67,19 @@        accts = ledgerRootAccount $ ledgerFromJournal q $ journalSelectingAmountFromOpts opts j       accts' :: [Account]-          | flat_ opts = dbg "accts" $ +          | queryDepth q == 0 =+                         dbg "accts" $+                         take 1 $ clipAccountsAndAggregate (queryDepth q) $ flattenAccounts accts+          | flat_ opts = dbg "accts" $                          filterzeros $                          filterempty $                          drop 1 $ clipAccountsAndAggregate (queryDepth q) $ flattenAccounts accts-          | otherwise  = dbg "accts" $ +          | otherwise  = dbg "accts" $                          filter (not.aboring) $                          drop 1 $ flattenAccounts $-                         markboring $ -                         prunezeros $ clipAccounts (queryDepth q) accts+                         markboring $+                         prunezeros $+                         clipAccounts (queryDepth q) accts           where             balance     = if flat_ opts then aebalance else aibalance             filterzeros = if empty_ opts then id else filter (not . isZeroMixedAmount . balance)@@ -99,14 +103,18 @@            | otherwise = a  balanceReportItem :: ReportOpts -> Query -> Account -> BalanceReportItem-balanceReportItem opts _ a@Account{aname=name}+balanceReportItem opts q a   | flat_ opts = ((name, name,       0),      (if flatShowsExclusiveBalance then aebalance else aibalance) a)   | otherwise  = ((name, elidedname, indent), aibalance a)   where+    name | queryDepth q > 0 = aname a+         | otherwise        = "..."     elidedname = accountNameFromComponents (adjacentboringparentnames ++ [accountLeafName name])     adjacentboringparentnames = reverse $ map (accountLeafName.aname) $ takeWhile aboring $ parents     indent = length $ filter (not.aboring) parents-    parents = init $ parentAccounts a+    -- parents exclude the tree's root node+    parents = case parentAccounts a of [] -> []+                                       as -> init as  -- -- the above using the newer multi balance report code: -- balanceReport' opts q j = (items, total)@@ -116,13 +124,14 @@ --     total = headDef 0 mbrtotals  tests_balanceReport =-  let (opts,journal) `gives` r = do-         let (eitems, etotal) = r-             (aitems, atotal) = balanceReport opts (queryFromOpts nulldate opts) journal-         assertEqual "items" eitems aitems-         -- assertEqual "" (length eitems) (length aitems)-         -- mapM (\(e,a) -> assertEqual "" e a) $ zip eitems aitems-         assertEqual "total" etotal atotal+  let+    (opts,journal) `gives` r = do+      let (eitems, etotal) = r+          (aitems, atotal) = balanceReport opts (queryFromOpts nulldate opts) journal+          showw (acct,amt) = (acct, showMixedAmountDebug amt)+      assertEqual "items" (map showw eitems) (map showw aitems)+      assertEqual "total" (showMixedAmountDebug etotal) (showMixedAmountDebug atotal)+    usd0 = nullamt{acommodity="$"}   in [     "balanceReport with no args on null journal" ~: do@@ -142,7 +151,7 @@      ,(("income:salary","salary",1), mamountp' "$-1.00")      ,(("liabilities:debts","liabilities:debts",0), mamountp' "$1.00")      ],-     Mixed [nullamt])+     Mixed [usd0])    ,"balanceReport with --depth=N" ~: do    (defreportopts{depth_=Just 1}, samplejournal) `gives`@@ -152,7 +161,7 @@      ,(("income",      "income",      0), mamountp' "$-2.00")      ,(("liabilities", "liabilities", 0), mamountp'  "$1.00")      ],-     Mixed [nullamt])+     Mixed [usd0])    ,"balanceReport with depth:N" ~: do    (defreportopts{query_="depth:1"}, samplejournal) `gives`@@ -162,18 +171,18 @@      ,(("income",      "income",      0), mamountp' "$-2.00")      ,(("liabilities", "liabilities", 0), mamountp'  "$1.00")      ],-     Mixed [nullamt])+     Mixed [usd0])    ,"balanceReport with a date or secondary date span" ~: do    (defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives`     ([],      Mixed [nullamt])-   (defreportopts{query_="edate:'in 2009'"}, samplejournal2) `gives`+   (defreportopts{query_="date2:'in 2009'"}, samplejournal2) `gives`     ([       (("assets:bank:checking","assets:bank:checking",0),mamountp' "$1.00")      ,(("income:salary","income:salary",0),mamountp' "$-1.00")      ],-     Mixed [nullamt])+     Mixed [usd0])    ,"balanceReport with desc:" ~: do    (defreportopts{query_="desc:income"}, samplejournal) `gives`@@ -181,13 +190,13 @@       (("assets:bank:checking","assets:bank:checking",0),mamountp' "$1.00")      ,(("income:salary","income:salary",0), mamountp' "$-1.00")      ],-     Mixed [nullamt])+     Mixed [usd0])    ,"balanceReport with not:desc:" ~: do    (defreportopts{query_="not:desc:income"}, samplejournal) `gives`     ([       (("assets","assets",0), mamountp' "$-2.00")-     ,(("assets:bank","bank",1), Mixed [nullamt])+     ,(("assets:bank","bank",1), Mixed [usd0])      ,(("assets:bank:checking","checking",2),mamountp' "$-1.00")      ,(("assets:bank:saving","saving",2), mamountp' "$1.00")      ,(("assets:cash","cash",1), mamountp' "$-2.00")@@ -197,7 +206,7 @@      ,(("income:gifts","income:gifts",0), mamountp' "$-1.00")      ,(("liabilities:debts","liabilities:debts",0), mamountp' "$1.00")      ],-     Mixed [nullamt])+     Mixed [usd0])   {-@@ -246,7 +255,7 @@      ,"                   0"      ] -    ,"accounts report with unmatched parent of two matched subaccounts" ~: +    ,"accounts report with unmatched parent of two matched subaccounts" ~:      defreportopts{patterns_=["cash","saving"]} `gives`      ["                 $-1  assets"      ,"                  $1    bank:saving"@@ -255,7 +264,7 @@      ,"                 $-1"      ] -    ,"accounts report with multi-part account name" ~: +    ,"accounts report with multi-part account name" ~:      defreportopts{patterns_=["expenses:food"]} `gives`      ["                  $1  expenses:food"      ,"--------------------"@@ -275,13 +284,13 @@      ,"                  $1"      ] -    ,"accounts report negative account pattern always matches full name" ~: +    ,"accounts report negative account pattern always matches full name" ~:      defreportopts{patterns_=["not:e"]} `gives`      ["--------------------"      ,"                   0"      ] -    ,"accounts report negative patterns affect totals" ~: +    ,"accounts report negative patterns affect totals" ~:      defreportopts{patterns_=["expenses","not:food"]} `gives`      ["                  $1  expenses:supplies"      ,"--------------------"@@ -316,10 +325,11 @@ -}  ] -Right samplejournal2 = journalBalanceTransactions $ +Right samplejournal2 = journalBalanceTransactions $          nulljournal          {jtxns = [            txnTieKnot $ Transaction {+             tsourcepos=nullsourcepos,              tdate=parsedate "2008/01/01",              tdate2=Just $ parsedate "2009/01/01",              tstatus=False,@@ -335,12 +345,12 @@            }           ]          }-         + -- tests_isInterestingIndented = [---   "isInterestingIndented" ~: do +--   "isInterestingIndented" ~: do --    let (opts, journal, acctname) `gives` r = isInterestingIndented opts l acctname `is` r --           where l = ledgerFromJournal (queryFromOpts nulldate opts) journal-     + --    (defreportopts, samplejournal, "expenses") `gives` True --  ] 

@@ -71,7 +71,7 @@       depthq     = dbg "depthq" $ filterQuery queryIsDepth q       depth      = queryDepth depthq       depthless  = dbg "depthless" . filterQuery (not . queryIsDepth)-      datelessq  = dbg "datelessq"  $ filterQuery (not . queryIsDate) q+      datelessq  = dbg "datelessq"  $ filterQuery (not . queryIsDateOrDate2) q       dateqcons  = if date2_ opts then Date2 else Date       precedingq = dbg "precedingq" $ And [datelessq, dateqcons $ DateSpan Nothing (spanStart reportspan)]       requestedspan  = dbg "requestedspan"  $ queryDateSpan (date2_ opts) q                              -- span specified by -b/-e/-p options and query args@@ -85,7 +85,7 @@       ps :: [Posting] =           dbg "ps" $           journalPostings $-          filterJournalPostingAmounts symq $     -- remove amount parts excluded by cur:+          filterJournalAmounts symq $     -- remove amount parts excluded by cur:           filterJournalPostings reportq $        -- remove postings not matched by (adjusted) query           journalSelectingAmountFromOpts opts j @@ -107,21 +107,30 @@             postingAcctBals :: [Posting] -> [(ClippedAccountName, MixedAmount)]             postingAcctBals ps = [(aname a, (if tree_ opts then aibalance else aebalance) a) | a <- as]                 where-                  as = depthLimit $ +                  as = depthLimit $                        (if tree_ opts then id else filter ((>0).anumpostings)) $                        drop 1 $ accountsFromPostings ps                   depthLimit                       | tree_ opts = filter ((depthq `matchesAccount`).aname) -- exclude deeper balances                       | otherwise  = clipAccountsAndAggregate depth -- aggregate deeper balances at the depth limit -      postedAccts :: [AccountName] =-          dbg "postedAccts" $-          sort $ accountNamesFromPostings ps+      postedAccts :: [AccountName] = dbg "postedAccts" $ sort $ accountNamesFromPostings ps +      -- starting balances and accounts from transactions before the report start date+      startacctbals = dbg "startacctbals" $ map (\((a,_,_),b) -> (a,b)) startbalanceitems+          where+            (startbalanceitems,_) = dbg "starting balance report" $ balanceReport opts' precedingq j+                                    where+                                      opts' | tree_ opts = opts{no_elide_=True}+                                            | otherwise  = opts{accountlistmode_=ALFlat}+      startingBalanceFor a = fromMaybe nullmixedamt $ lookup a startacctbals+      startAccts = dbg "startAccts" $ map fst startacctbals+       displayedAccts :: [ClippedAccountName] =           dbg "displayedAccts" $           (if tree_ opts then expandAccountNames else id) $-          nub $ map (clipAccountName depth) postedAccts+          nub $ map (clipOrEllipsifyAccountName depth) $+          if empty_ opts then nub $ sort $ startAccts ++ postedAccts else postedAccts        acctBalChangesPerSpan :: [[(ClippedAccountName, MixedAmount)]] =           dbg "acctBalChangesPerSpan" $@@ -133,15 +142,6 @@           dbg "acctBalChanges" $           [(a, map snd abs) | abs@((a,_):_) <- transpose acctBalChangesPerSpan] -- never null, or used when null... -      -- starting balances and accounts from transactions before the report start date-      startacctbals = dbg "startacctbals" $ map (\((a,_,_),b) -> (a,b)) $ startbalanceitems-          where-            (startbalanceitems,_) = dbg "starting balance report" $ balanceReport opts' precedingq j-                                    where-                                      opts' | tree_ opts = opts{no_elide_=True}-                                            | otherwise  = opts{flat_=True}-      startingBalanceFor a = fromMaybe nullmixedamt $ lookup a startacctbals-       items :: [MultiBalanceReportRow] =           dbg "items" $           [((a, accountLeafName a, accountNameLevel a), displayedBals)@@ -150,7 +150,7 @@                                   HistoricalBalance -> drop 1 $ scanl (+) (startingBalanceFor a) changes                                   CumulativeBalance -> drop 1 $ scanl (+) nullmixedamt changes                                   _                 -> changes-           , empty_ opts || any (not . isZeroMixedAmount) displayedBals+           , empty_ opts || depth == 0 || any (not . isZeroMixedAmount) displayedBals            ]        totals :: [MixedAmount] =@@ -162,6 +162,6 @@                 dbg "highestlevelaccts" $                 [a | a <- displayedAccts, not $ any (`elem` displayedAccts) $ init $ expandAccountName a] -      dbg s = let p = "multiBalanceReport" in Hledger.Utils.dbg (p++" "++s)  -- add prefix in debug output-      -- dbg = const id  -- exclude from debug output+      dbg s = let p = "multiBalanceReport" in Hledger.Utils.dbg (p++" "++s)  -- add prefix in this function's debug output+      -- dbg = const id  -- exclude this function from debug output 

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-}+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances, TupleSections #-} {-|  Postings report, used by the register command.@@ -35,10 +35,17 @@ type PostingsReport = (String               -- label for the running balance column XXX remove                       ,[PostingsReportItem] -- line items, one per posting                       )-type PostingsReportItem = (Maybe Day    -- posting date, if this is the first posting in a transaction or if it's different from the previous posting's date-                          ,Maybe String -- transaction description, if this is the first posting in a transaction-                          ,Posting      -- the posting, possibly with account name depth-clipped-                          ,MixedAmount  -- the running total after this posting (or with --average, the running average)+type PostingsReportItem = (Maybe Day    -- The posting date, if this is the first posting in a+                                        -- transaction or if it's different from the previous+                                        -- posting's date. Or if this a summary posting, the+                                        -- report interval's start date if this is the first+                                        -- summary posting in the interval.+                          ,Maybe Day    -- If this is a summary posting, the report interval's+                                        -- end date if this is the first summary posting in+                                        -- the interval.+                          ,Maybe String -- The posting's transaction's description, if this is the first posting in the transaction.+                          ,Posting      -- The posting, possibly with the account name depth-clipped.+                          ,MixedAmount  -- The running total after this posting (or with --average, the running average).                           )  -- | Select postings from the journal and add running balance and other@@ -50,11 +57,13 @@       symq = dbg "symq"   $ filterQuery queryIsSym $ dbg "requested q" q       depth = queryDepth q       depthless = filterQuery (not . queryIsDepth)-      datelessq = filterQuery (not . queryIsDate) q-      (dateqcons,pdate) | date2_ opts = (Date2, postingDate2)-                        | otherwise   = (Date, postingDate)-      requestedspan  = dbg "requestedspan"  $ queryDateSpan (date2_ opts) q                              -- span specified by -b/-e/-p options and query args-      requestedspan' = dbg "requestedspan'" $ requestedspan `spanDefaultsFrom` journalDateSpan (date2_ opts) j  -- if open-ended, close it using the journal's end dates+      datelessq = filterQuery (not . queryIsDateOrDate2) q+      -- XXX date:/date2:/--date2 handling is not robust, combinations of these can confuse it+      dateq = filterQuery queryIsDateOrDate2 q+      (dateqcons,pdate) | queryIsDate2 dateq || (queryIsDate dateq && date2_ opts) = (Date2, postingDate2)+                        | otherwise = (Date, postingDate)+      requestedspan  = dbg "requestedspan"  $ queryDateSpan' q   -- span specified by -b/-e/-p options and query args+      requestedspan' = dbg "requestedspan'" $ requestedspan `spanDefaultsFrom` journalDateSpan ({-date2_ opts-} False) j  -- if open-ended, close it using the journal's end dates       intervalspans  = dbg "intervalspans"  $ splitSpan (intervalFromOpts opts) requestedspan' -- interval spans enclosing it       reportstart    = dbg "reportstart"    $ maybe Nothing spanStart $ headMay intervalspans       reportend      = dbg "reportend"      $ maybe Nothing spanEnd   $ lastMay intervalspans@@ -63,7 +72,7 @@       beforeendq     = dbg "beforeendq"     $ dateqcons $ DateSpan Nothing reportend       reportq        = dbg "reportq"        $ depthless $ And [datelessq, beforeendq] -- user's query with no start date, end date on an interval boundary and no depth limit -      pstoend = +      pstoend =           dbg "ps4" $ sortBy (comparing pdate) $                                  -- sort postings by date (or date2)           dbg "ps3" $ map (filterPostingAmount symq) $                            -- remove amount parts which the query's cur: terms would exclude           dbg "ps2" $ (if related_ opts then concatMap relatedPostings else id) $ -- with -r, replace each with its sibling postings@@ -71,14 +80,14 @@                       journalPostings $ journalSelectingAmountFromOpts opts j       (precedingps, reportps) = dbg "precedingps, reportps" $ span (beforestartq `matchesPosting`) pstoend -      empty = queryEmpty q+      showempty = queryEmpty q || average_ opts       -- displayexpr = display_ opts  -- XXX       interval = intervalFromOpts opts -- XXX        whichdate = whichDateFromOpts opts-      itemps | interval == NoInterval = reportps-             | otherwise              = summarisePostingsByInterval interval whichdate depth empty reportspan reportps-      items = postingsReportItems itemps nullposting whichdate depth startbal runningcalc 1+      itemps | interval == NoInterval = map (,Nothing) reportps+             | otherwise              = summarisePostingsByInterval interval whichdate depth showempty reportspan reportps+      items = dbg "items" $ postingsReportItems itemps (nullposting,Nothing) whichdate depth startbal runningcalc 1         where           startbal = if balancetype_ opts == HistoricalBalance then sumPostings precedingps else 0           runningcalc | average_ opts = \i avg amt -> avg + (amt - avg) `divideMixedAmount` (fromIntegral i) -- running average@@ -89,37 +98,43 @@  totallabel = "Total" --- | Generate postings report line items.-postingsReportItems :: [Posting] -> Posting -> WhichDate -> Int -> MixedAmount -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) -> Int -> [PostingsReportItem]+-- | Generate postings report line items from a list of postings or (with+-- non-Nothing dates attached) summary postings.+postingsReportItems :: [(Posting,Maybe Day)] -> (Posting,Maybe Day) -> WhichDate -> Int -> MixedAmount -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) -> Int -> [PostingsReportItem] postingsReportItems [] _ _ _ _ _ _ = []-postingsReportItems (p:ps) pprev wd d b runningcalcfn itemnum = i:(postingsReportItems ps p wd d b' runningcalcfn (itemnum+1))+postingsReportItems ((p,menddate):ps) (pprev,menddateprev) wd d b runningcalcfn itemnum = i:(postingsReportItems ps (p,menddate) wd d b' runningcalcfn (itemnum+1))     where-      i = mkpostingsReportItem showdate showdesc wd p' b'-      showdate = isfirstintxn || isdifferentdate-      showdesc = isfirstintxn+      i = mkpostingsReportItem showdate showdesc wd menddate p' b'+      (showdate, showdesc) | isJust menddate = (menddate /= menddateprev,        False)+                           | otherwise       = (isfirstintxn || isdifferentdate, isfirstintxn)       isfirstintxn = ptransaction p /= ptransaction pprev       isdifferentdate = case wd of PrimaryDate   -> postingDate p  /= postingDate pprev                                    SecondaryDate -> postingDate2 p /= postingDate2 pprev-      p' = p{paccount=clipAccountName d $ paccount p}+      p' = p{paccount= clipOrEllipsifyAccountName d $ paccount p}       b' = runningcalcfn itemnum b (pamount p)  -- | Generate one postings report line item, containing the posting, -- the current running balance, and optionally the posting date and/or -- the transaction description.-mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Posting -> MixedAmount -> PostingsReportItem-mkpostingsReportItem showdate showdesc wd p b = (if showdate then Just date else Nothing, if showdesc then Just desc else Nothing, p, b)-    where-      date = case wd of PrimaryDate   -> postingDate p-                        SecondaryDate -> postingDate2 p-      desc = maybe "" tdescription $ ptransaction p+mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Maybe Day -> Posting -> MixedAmount -> PostingsReportItem+mkpostingsReportItem showdate showdesc wd menddate p b =+  (if showdate then Just date else Nothing+  ,menddate+  ,if showdesc then Just desc else Nothing+  ,p+  ,b+  )+  where+    date = case wd of PrimaryDate   -> postingDate p+                      SecondaryDate -> postingDate2 p+    desc = maybe "" tdescription $ ptransaction p --- | 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 -> WhichDate -> Int -> Bool -> DateSpan -> [Posting] -> [Posting]-summarisePostingsByInterval interval wd depth empty reportspan ps = concatMap summarisespan $ splitSpan interval reportspan+-- | Convert a list of postings into summary postings, one per interval,+-- aggregated to the specified depth if any.+summarisePostingsByInterval :: Interval -> WhichDate -> Int -> Bool -> DateSpan -> [Posting] -> [SummaryPosting]+summarisePostingsByInterval interval wd depth showempty reportspan ps = concatMap summarisespan $ splitSpan interval reportspan     where-      summarisespan s = summarisePostingsInDateSpan s wd depth empty (postingsinspan s)+      summarisespan s = summarisePostingsInDateSpan s wd depth showempty (postingsinspan s)       postingsinspan s = filter (isPostingInDateSpan' wd s) ps  tests_summarisePostingsByInterval = [@@ -127,37 +142,43 @@     summarisePostingsByInterval (Quarters 1) PrimaryDate 99999 False (DateSpan Nothing Nothing) [] ~?= []  ] +-- | A summary posting summarises the activity in one account within a report+-- interval. It is currently kludgily represented by a regular Posting with no+-- description, the interval's start date stored as the posting date, and the+-- interval's end date attached with a tuple.+type SummaryPosting = (Posting, Maybe Day)+ -- | 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.+-- postings within it, aggregate the postings into one summary posting per+-- account. -- -- When a depth argument is present, postings to accounts of greater--- depth are aggregated where possible.+-- depth are also aggregated where possible. If the depth is 0, all+-- postings in the span are aggregated into a single posting with+-- account name "...". -- -- The showempty flag includes spans with no postings and also postings -- with 0 amount.-summarisePostingsInDateSpan :: DateSpan -> WhichDate -> Int -> Bool -> [Posting] -> [Posting]+--+summarisePostingsInDateSpan :: DateSpan -> WhichDate -> Int -> Bool -> [Posting] -> [SummaryPosting] summarisePostingsInDateSpan (DateSpan b e) wd depth showempty ps     | null ps && (isNothing b || isNothing e) = []-    | null ps && showempty = [summaryp]-    | otherwise = summaryps'+    | null ps && showempty = [(summaryp, Just e')]+    | otherwise = summarypes     where-      summaryp = summaryPosting b' ("- "++ showDate (addDays (-1) e'))+      postingdate = if wd == PrimaryDate then postingDate else postingDate2       b' = fromMaybe (maybe nulldate postingdate $ headMay ps) b       e' = fromMaybe (maybe (addDays 1 nulldate) postingdate $ lastMay ps) e-      postingdate = if wd == PrimaryDate then postingDate else postingDate2-      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=balance a} | a <- clippedanames]-      clippedanames = nub $ map (clipAccountName depth) anames+      summaryp = nullposting{pdate=Just b'}+      clippedanames | depth > 0 = nub $ map (clipAccountName depth) anames+                    | otherwise = ["..."]+      summaryps | depth > 0 = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames]+                | otherwise = [summaryp{paccount="...",pamount=sum $ map pamount ps}]+      summarypes = map (, Just e') $ (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps       anames = sort $ nub $ map paccount ps       -- aggregate balances by account, like ledgerFromJournal, then do depth-clipping       accts = accountsFromPostings ps-      balance a = maybe nullmixedamt bal $ lookupAccount a accts +      balance a = maybe nullmixedamt bal $ lookupAccount a accts         where           bal = if isclipped a then aibalance else aebalance           isclipped a = accountNameLevel a >= depth@@ -247,7 +268,7 @@      ]    ,"postings report with cleared option" ~:-   do +   do     let opts = defreportopts{cleared_=True}     j <- readJournal' sample_journal_str     (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines@@ -259,7 +280,7 @@      ]    ,"postings report with uncleared option" ~:-   do +   do     let opts = defreportopts{uncleared_=True}     j <- readJournal' sample_journal_str     (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines@@ -272,7 +293,7 @@      ]    ,"postings report sorts by date" ~:-   do +   do     j <- readJournal' $ unlines         ["2008/02/02 a"         ,"  b  1"@@ -294,7 +315,7 @@      ]    ,"postings report with account pattern, case insensitive" ~:-   do +   do     j <- samplejournal     let opts = defreportopts{patterns_=["cAsH"]}     (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines@@ -302,9 +323,9 @@      ]    ,"postings report with display expression" ~:-   do +   do     j <- samplejournal-    let gives displayexpr = +    let gives displayexpr =             (registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is`)                 where opts = defreportopts{display_=Just displayexpr}     "d<[2008/6/2]"  `gives` ["2008/01/01","2008/06/01"]@@ -314,7 +335,7 @@     "d>[2008/6/2]"  `gives` ["2008/06/03","2008/12/31"]    ,"postings report with period expression" ~:-   do +   do     j <- samplejournal     let periodexpr `gives` dates = do           j' <- samplejournal@@ -344,7 +365,7 @@   ]    , "postings report with depth arg" ~:-   do +   do     j <- samplejournal     let opts = defreportopts{depth_=Just 2}     (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines

@@ -8,9 +8,12 @@ module Hledger.Reports.ReportOptions (   ReportOpts(..),   BalanceType(..),+  AccountListMode(..),   FormatStr,   defreportopts,   rawOptsToReportOpts,+  flat_,+  tree_,   dateSpanFromOpts,   intervalFromOpts,   clearedValueFromOpts,@@ -47,6 +50,11 @@  instance Default BalanceType where def = PeriodBalance +-- | Should accounts be displayed: in the command's default style, hierarchically, or as a flat list ?+data AccountListMode = ALDefault | ALTree | ALFlat deriving (Eq, Show, Data, Typeable)++instance Default AccountListMode where def = ALDefault+ -- | Standard options for customising report filtering and output, -- corresponding to hledger's command-line options and query language -- arguments. Used in hledger-lib and above.@@ -75,8 +83,7 @@     ,related_        :: Bool     -- balance     ,balancetype_    :: BalanceType-    ,flat_           :: Bool -- mutually-    ,tree_           :: Bool -- exclusive+    ,accountlistmode_  :: AccountListMode     ,drop_           :: Int     ,no_total_       :: Bool  } deriving (Show, Data, Typeable)@@ -110,7 +117,6 @@     def     def     def-    def  rawOptsToReportOpts :: RawOpts -> IO ReportOpts rawOptsToReportOpts rawopts = do@@ -138,12 +144,18 @@     ,average_     = boolopt "average" rawopts     ,related_     = boolopt "related" rawopts     ,balancetype_ = balancetypeopt rawopts-    ,flat_        = boolopt "flat" rawopts-    ,tree_        = boolopt "tree" rawopts+    ,accountlistmode_ = accountlistmodeopt rawopts     ,drop_        = intopt "drop" rawopts     ,no_total_    = boolopt "no-total" rawopts     } +accountlistmodeopt :: RawOpts -> AccountListMode+accountlistmodeopt rawopts =+  case reverse $ filter (`elem` ["tree","flat"]) $ map fst rawopts of+    ("tree":_) -> ALTree+    ("flat":_) -> ALFlat+    _          -> ALDefault+ balancetypeopt :: RawOpts -> BalanceType balancetypeopt rawopts     | length [o | o <- ["cumulative","historical"], isset o] > 1@@ -181,6 +193,13 @@                 Just                 $ parsePeriodExpr d s +-- | Legacy-compatible convenience aliases for accountlistmode_.+tree_ :: ReportOpts -> Bool+tree_ = (==ALTree) . accountlistmode_++flat_ :: ReportOpts -> Bool+flat_ = (==ALFlat) . accountlistmode_+ -- | 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.@@ -266,7 +285,7 @@                                                       ,query_="date:'to 2013'"                                                       })   assertEqual "" (Date2 $ mkdatespan "2012/01/01" "2013/01/01")-                 (queryFromOpts nulldate defreportopts{query_="edate:'in 2012'"})+                 (queryFromOpts nulldate defreportopts{query_="date2:'in 2012'"})   assertEqual "" (Or [Acct "a a", Acct "'b"])                  (queryFromOpts nulldate defreportopts{query_="'a a' 'b"})  ]

@@ -1,16 +1,22 @@ {-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} {-| -Whole-journal, account-centric, and per-commodity transactions reports, used by hledger-web.+Here are several variants of a transactions report.+Transactions reports are like a postings report, but more+transaction-oriented, and (in the account-centric variant) relative to+a some base account.  They are used by hledger-web.  -}  module Hledger.Reports.TransactionsReports (   TransactionsReport,   TransactionsReportItem,+  triOrigTransaction,   triDate,+  triAmount,   triBalance,-  triSimpleBalance,+  triCommodityAmount,+  triCommodityBalance,   journalTransactionsReport,   accountTransactionsReport,   transactionsReportByCommodity@@ -21,7 +27,6 @@ where  import Data.List-import Data.Maybe import Data.Ord -- import Test.HUnit @@ -40,59 +45,86 @@ 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+type TransactionsReportItem = (Transaction -- the original journal transaction, unmodified+                              ,Transaction -- the transaction as seen from a particular account                               ,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+triOrigTransaction (torig,_,_,_,_,_) = torig+triDate (_,tacct,_,_,_,_) = tdate tacct triAmount (_,_,_,_,a,_) = a triBalance (_,_,_,_,_,a) = a-triSimpleBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0"-                                                 (Amount{aquantity=q}):_ -> show q+triCommodityAmount c = filterMixedAmountByCommodity c  . triAmount+triCommodityBalance c = filterMixedAmountByCommodity c  . triBalance  -------------------------------------------------------------------------------  -- | Select transactions from the whole journal. This is similar to a -- "postingsReport" except with transaction-based report items which--- are ordered most recent first. This is used by eg hledger-web's journal view.+-- are ordered most recent first. XXX Or an EntriesReport - use that instead ?+-- This is used by hledger-web's journal view. journalTransactionsReport :: ReportOpts -> Journal -> Query -> TransactionsReport-journalTransactionsReport _ Journal{jtxns=ts} m = (totallabel, items)+journalTransactionsReport opts j q = (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+     items = reverse $ accountTransactionsReportItems q None nullmixedamt id ts+     ts    = sortBy (comparing date) $ filter (q `matchesTransaction`) $ jtxns $ journalSelectingAmountFromOpts opts j+     date  = transactionDateFn opts  ------------------------------------------------------------------------------- --- | Select transactions within one or more current accounts, and make a--- transactions report relative to those account(s). This means:+-- | An account transactions report represents transactions affecting+-- a particular account (or possibly several accounts, but we don't+-- use that). It is used by hledger-web's account register view, where+-- we want to show one row per journal transaction, with: ----- 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. +-- - the total increase/decrease to the current account ----- 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.+-- - the names of the other account(s) posted to/from ----- This is used by eg hledger-web's account register view. Currently,--- reporting intervals are not supported, and report items are most--- recent first.-accountTransactionsReport :: ReportOpts -> Journal -> Query -> Query -> TransactionsReport-accountTransactionsReport opts j m thisacctquery = (label, items)+-- - transaction dates adjusted to the date of the earliest posting to+--   the current account, if those postings have their own dates+--+-- Currently, reporting intervals are not supported, and report items+-- are most recent first.+--+type AccountTransactionsReport =+  (String                          -- label for the balance column, eg "balance" or "total"+  ,[AccountTransactionsReportItem] -- line items, one per transaction+  )++type AccountTransactionsReportItem =+  (+   Transaction -- the original journal transaction+  ,Transaction -- the adjusted account transaction+  ,Bool        -- is this a split, ie with more than one posting to other account(s)+  ,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+  )++accountTransactionsReport :: ReportOpts -> Journal -> Query -> Query -> AccountTransactionsReport+accountTransactionsReport opts j q thisacctquery = (label, items)  where-     -- transactions affecting this account, in date order-     ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctquery) $ jtxns $-          journalSelectingAmountFromOpts opts j+     -- transactions with excluded currencies removed+     ts1 = jtxns $+           filterJournalAmounts (filterQuery queryIsSym q) $+           journalSelectingAmountFromOpts opts j+     -- affecting this account+     ts2 = filter (matchesTransaction thisacctquery) ts1+     -- with dates adjusted for account transactions report+     ts3 = map (setTransactionDateToPostingDate q thisacctquery) ts2+     -- and sorted+     ts = sortBy (comparing tdate) ts3+      -- 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) | queryIsNull m                           = (nullmixedamt,        balancelabel)-                      | queryIsStartDateOnly (date2_ opts) m = (sumPostings priorps, balancelabel)-                      | otherwise                                 = (nullmixedamt,        totallabel)+     (startbal,label) | queryIsNull q                        = (nullmixedamt,        balancelabel)+                      | queryIsStartDateOnly (date2_ opts) q = (sumPostings priorps, balancelabel)+                      | otherwise                            = (nullmixedamt,        totallabel)                       where                         priorps = -- ltrace "priorps" $                                   filter (matchesPosting@@ -100,50 +132,70 @@                                            And [thisacctquery, tostartdatequery]))                                          $ transactionsPostings ts                         tostartdatequery = Date (DateSpan Nothing startdate)-                        startdate = queryStartDate (date2_ opts) m-     items = reverse $ accountTransactionsReportItems m (Just thisacctquery) startbal negate ts+                        startdate = queryStartDate (date2_ opts) q -totallabel = "Total"-balancelabel = "Balance"+     items = reverse $ -- see also registerChartHtml+             accountTransactionsReportItems q thisacctquery startbal negate ts +-- | Adjust a transaction's date to the earliest date of postings to a+-- particular account, if any, after filtering with a certain query.+setTransactionDateToPostingDate :: Query -> Query -> Transaction -> Transaction+setTransactionDateToPostingDate query thisacctquery t = t'+  where+    queryps = tpostings $ filterTransactionPostings query t+    thisacctps = filter (matchesPosting thisacctquery) queryps+    t' = case thisacctps of+          [] -> t+          _  -> t{tdate=d}+            where+              d | null ds   = tdate t+                | otherwise = minimum ds+              ds = map postingDate thisacctps+                   -- no opts here, don't even bother with that date/date2 rigmarole++totallabel = "Running Total"+balancelabel = "Historical Balance"+ -- | Generate transactions report items from a list of transactions,--- using the provided query and current account queries, starting balance,--- sign-setting function and balance-summing function.-accountTransactionsReportItems :: Query -> Maybe Query -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem]+-- using the provided query and current account queries, starting+-- balance, sign-setting function and balance-summing function. With a+-- "this account" query of None, this can be used the for the+-- journalTransactionsReport also.+accountTransactionsReportItems :: Query -> Query -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem] accountTransactionsReportItems _ _ _ _ [] = []-accountTransactionsReportItems query thisacctquery bal signfn (t:ts) =+accountTransactionsReportItems query thisacctquery bal signfn (torig: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 query t-      (psthisacct,psotheracct) = case thisacctquery of Just m  -> partition (matchesPosting m) psmatched-                                                       Nothing -> ([],psmatched)-      numotheraccts = length $ nub $ map paccount psotheracct-      amt = negate $ sum $ map pamount psthisacct-      acct | isNothing thisacctquery = 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+      -- XXX I've lost my grip on this, let's just hope for the best+      origps = tpostings torig+      tacct@Transaction{tpostings=queryps} = filterTransactionPostings query torig+      (thisacctps, otheracctps) = partition (matchesPosting thisacctquery) origps+      amt = negate $ sum $ map pamount thisacctps+      numotheraccts = length $ nub $ map paccount otheracctps+      otheracctstr | thisacctquery == None = summarisePostingAccounts origps+                   | numotheraccts == 0    = summarisePostingAccounts thisacctps+                   | otherwise             = summarisePostingAccounts otheracctps+      (i,bal') = case queryps of            [] -> (Nothing,bal)-           _  -> (Just (t, tmatched, numotheraccts > 1, acct, a, b), b)+           _  -> (Just (torig, tacct, numotheraccts > 1, otheracctstr, a, b), b)                  where                   a = signfn amt                   b = bal + a       is = accountTransactionsReportItems query thisacctquery 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 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@@ -156,9 +208,9 @@  -- | Split a transactions report whose items may involve several commodities, -- into one or more single-commodity transactions reports.-transactionsReportByCommodity :: TransactionsReport -> [TransactionsReport]+transactionsReportByCommodity :: TransactionsReport -> [(Commodity, TransactionsReport)] transactionsReportByCommodity tr =-  [filterTransactionsReportByCommodity c tr | c <- transactionsReportCommodities tr]+  [(c, filterTransactionsReportByCommodity c tr) | c <- transactionsReportCommodities tr]   where     transactionsReportCommodities (_,items) =       nub $ sort $ map acommodity $ concatMap (amounts . triAmount) items@@ -187,10 +239,6 @@         go _ [] = []         go bal ((t,t2,s,o,amt,_):is) = (t,t2,s,o,amt,bal'):go bal' is           where bal' = bal + amt---- | Filter out all but the specified commodity from this amount.-filterMixedAmountByCommodity :: Commodity -> MixedAmount -> MixedAmount-filterMixedAmountByCommodity c (Mixed as) = Mixed $ filter ((==c). acommodity) as  ------------------------------------------------------------------------------- 

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-|  Standard imports and utilities which are useful everywhere, or needed low@@ -14,69 +14,62 @@                           -- 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,+                          module Hledger.Utils.Debug,+                          module Hledger.Utils.Regex,+                          -- Debug.Trace.trace,                           -- module Data.PPrint,                           -- module Hledger.Utils.UTF8IOCompat                           SystemString,fromSystemString,toSystemString,error',userError',-#if __GLASGOW_HASKELL__ >= 704-                          ppShow-#endif                           -- the rest need to be done in each module I think                           ) where-import Control.Monad (liftM, when)+import Control.Monad (liftM) import Control.Monad.Error (MonadIO) import Control.Monad.IO.Class (liftIO) import Data.Char import Data.List import qualified Data.Map as M-import Data.Maybe+-- import Data.Maybe -- import Data.PPrint import Data.Time.Clock import Data.Time.LocalTime import Data.Tree-import Debug.Trace-import Safe (readDef) import System.Directory (getHomeDirectory)-import System.Environment (getArgs)-import System.Exit import System.FilePath((</>), isRelative) import System.IO-import System.IO.Unsafe (unsafePerformIO) import Test.HUnit-import Text.ParserCombinators.Parsec+import Text.Parsec import Text.Printf-import Text.Regex.TDFA-import Text.RegexPR -- import qualified Data.Map as Map--- ++import Hledger.Utils.Debug+import Hledger.Utils.Regex -- import Prelude hiding (readFile,writeFile,appendFile,getContents,putStr,putStrLn) -- import Hledger.Utils.UTF8IOCompat   (readFile,writeFile,appendFile,getContents,putStr,putStrLn) import Hledger.Utils.UTF8IOCompat (SystemString,fromSystemString,toSystemString,error',userError') -#if __GLASGOW_HASKELL__ >= 704-import Text.Show.Pretty (ppShow)-#else--- the required pretty-show version requires GHC >= 7.4-ppShow :: Show a => a -> String-ppShow = show-#endif- -- strings  lowercase = map toLower uppercase = map toUpper +-- | Remove leading and trailing whitespace. strip = lstrip . rstrip-lstrip = dropWhile (`elem` " \t") :: String -> String++-- | Remove leading whitespace.+lstrip = dropWhile (`elem` " \t") :: String -> String -- XXX isSpace ?++-- | Remove trailing whitespace. rstrip = reverse . lstrip . reverse +-- | Remove trailing newlines/carriage returns.+chomp = reverse . dropWhile (`elem` "\r\n") . reverse+ stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String  elideLeft width s =@@ -248,54 +241,17 @@ difforzero :: (Num a, Ord a) => a -> a -> a difforzero a b = maximum [(a - b), 0] --- regexps--- Note many of these will die on malformed 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--regexSplit :: String -> String -> [String]-regexSplit = splitRegexPR---- regex-compat (regex-posix) functions that perform better than regexpr.-regexMatchesRegexCompat :: String -> String -> Bool-regexMatchesRegexCompat = flip (=~)--regexMatchesCIRegexCompat :: String -> String -> Bool-regexMatchesCIRegexCompat r = match (makeRegexOpts defaultCompOpt { multiline = True, caseSensitive = False, newSyntax = True } defaultExecOpt 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'+splitAtElement x l =+  case l of+    []          -> []+    e:es | e==x -> split es+    es          -> split es+  where+    split es = let (first,rest) = break (x==) es+               in first : splitAtElement x rest  -- trees @@ -324,7 +280,7 @@ 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) []@@ -336,15 +292,15 @@  -- | remove all subtrees whose nodes do not fulfill predicate treefilter :: (a -> Bool) -> Tree a -> Tree a-treefilter f t = Node -                 (root t) +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. ++-- treedrop -- remove the leaves which do fulfill predicate. -- treedropall -- do this repeatedly.  -- | show a compact ascii representation of a tree@@ -374,146 +330,18 @@ treeFromPaths = foldl' mergeTrees emptyTree . map treeFromPath  --- debugging---- more:--- http://hackage.haskell.org/packages/archive/TraceUtils/0.1.0.2/doc/html/Debug-TraceUtils.html--- http://hackage.haskell.org/packages/archive/trace-call/0.1/doc/html/Debug-TraceCall.html--- http://hackage.haskell.org/packages/archive/htrace/0.1/doc/html/Debug-HTrace.html--- http://hackage.haskell.org/packages/archive/traced/2009.7.20/doc/html/Debug-Traced.html---- | Trace (print on stdout at runtime) a showable value.--- (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---- | Custom trace - like strace, with a custom show function.-traceWith :: (a -> String) -> a -> a-traceWith f e = trace (f e) e---- | Parsec trace - show the current parsec position and next input,--- and the provided label if it's non-null.-ptrace :: String -> GenParser Char st ()-ptrace msg = do-  pos <- getPosition-  next <- take peeklength `fmap` getInput-  let (l,c) = (sourceLine pos, sourceColumn pos)-      s  = printf "at line %2d col %2d: %s" l c (show next) :: String-      s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg-  trace s' $ return ()-  where-    peeklength = 30---- | Global debug level, which controls the verbosity of debug output--- on the console. The default is 0 meaning no debug output. The--- @--debug@ command line flag sets it to 1, or @--debug=N@ sets it to--- a higher value (note: not @--debug N@ for some reason).  This uses--- unsafePerformIO and can be accessed from anywhere and before normal--- command-line processing. After command-line processing, it is also--- available as the @debug_@ field of 'Hledger.Cli.Options.CliOpts'.-debugLevel :: Int-debugLevel = case snd $ break (=="--debug") args of-               "--debug":[]  -> 1-               "--debug":n:_ -> readDef 1 n-               _             ->-                 case take 1 $ filter ("--debug" `isPrefixOf`) args of-                   ['-':'-':'d':'e':'b':'u':'g':'=':v] -> readDef 1 v-                   _                                   -> 0--    where-      args = unsafePerformIO getArgs---- | Print a message and a showable value to the console if the global--- debug level is non-zero.  Uses unsafePerformIO.-dbg :: Show a => String -> a -> a-dbg = dbg1--dbg0 :: Show a => String -> a -> a-dbg0 = dbgAt 0--dbg1 :: Show a => String -> a -> a-dbg1 = dbgAt 1--dbg2 :: Show a => String -> a -> a-dbg2 = dbgAt 2---- | Print a message and a showable value to the console if the global--- debug level is at or above the specified level.  Uses unsafePerformIO.-dbgAt :: Show a => Int -> String -> a -> a-dbgAt lvl = dbgppshow lvl--dbgAtM :: Show a => Int -> String -> a -> IO ()-dbgAtM lvl lbl x = dbgAt lvl lbl x `seq` return ()---- | Print a showable value to the console, with a message, if the--- debug level is at or above the specified level (uses--- unsafePerformIO).--- Values are displayed with show, all on one line, which is hard to read.-dbgshow :: Show a => Int -> String -> a -> a-dbgshow level-    | debugLevel >= level = ltrace-    | otherwise           = flip const---- | Print a showable value to the console, with a message, if the--- debug level is at or above the specified level (uses--- unsafePerformIO).--- Values are displayed with ppShow, each field/constructor on its own line.-dbgppshow :: Show a => Int -> String -> a -> a-dbgppshow level-    | debugLevel < level = flip const-    | otherwise = \s a -> let p = ppShow a-                              ls = lines p-                              nlorspace | length ls > 1 = "\n"-                                        | otherwise     = " " ++ take (10 - length s) (repeat ' ')-                              ls' | length ls > 1 = map (" "++) ls-                                  | otherwise     = ls-                          in trace (s++":"++nlorspace++intercalate "\n" ls') a---- -- | Print a showable value to the console, with a message, if the--- -- debug level is at or above the specified level (uses--- -- unsafePerformIO).--- -- Values are displayed with pprint. Field names are not shown, but the--- -- output is compact with smart line wrapping, long data elided,--- -- and slow calculations timed out.--- dbgpprint :: Data a => Int -> String -> a -> a--- dbgpprint level msg a---     | debugLevel >= level = unsafePerformIO $ do---                               pprint a >>= putStrLn . ((msg++": \n") ++) . show---                               return a---     | otherwise           = a----- | Like dbg, then exit the program. Uses unsafePerformIO.-dbgExit :: Show a => String -> a -> a-dbgExit msg = const (unsafePerformIO exitFailure) . dbg msg---- | Print a message and parsec debug info (parse position and next--- input) to the console when the debug level is at or above--- this level. Uses unsafePerformIO.--- pdbgAt :: GenParser m => Float -> String -> m ()-pdbg level msg = when (level <= debugLevel) $ ptrace msg-- -- 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+choice' :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a+choice' = choice . map Text.Parsec.try -parsewith :: Parser a -> String -> Either ParseError a-parsewith p = parse p ""+parsewith :: Parsec [Char] () a -> String -> Either ParseError a+parsewith p = runParser p () "" -parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a-parseWithCtx ctx p = runParser p ctx ""+parseWithCtx :: Stream s m t => u -> ParsecT s u m a -> s -> m (Either ParseError a)+parseWithCtx ctx p = runParserT p ctx ""  fromparse :: Either ParseError a -> a fromparse = either parseerror id@@ -527,16 +355,16 @@ showDateParseError :: ParseError -> String showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e) -nonspace :: GenParser Char st Char+nonspace :: (Stream [Char] m Char) => ParsecT [Char] st m Char nonspace = satisfy (not . isSpace) -spacenonewline :: GenParser Char st Char+spacenonewline :: (Stream [Char] m Char) => ParsecT [Char] st m Char spacenonewline = satisfy (`elem` " \v\f\t") -restofline :: GenParser Char st String+restofline :: (Stream [Char] m Char) => ParsecT [Char] st m String restofline = anyChar `manyTill` newline -eolof :: GenParser Char st ()+eolof :: (Stream [Char] m Char) => ParsecT [Char] st m () eolof = (newline >> return ()) <|> eof  -- time@@ -599,7 +427,7 @@ applyN n f = (!! n) . iterate f  -- | Convert a possibly relative, possibly tilde-containing file path to an absolute one,--- given the current directory. ~username is not supported. Leave "-" unchanged. +-- given the current directory. ~username is not supported. Leave "-" unchanged. expandPath :: MonadIO m => FilePath -> FilePath -> m FilePath -- general type sig for use in reader parsers expandPath _ "-" = return "-" expandPath curdir p = (if isRelative p then (curdir </>) else id) `liftM` expandPath' p

@@ -0,0 +1,205 @@+{-# LANGUAGE CPP, FlexibleContexts #-}+-- | Debugging helpers++-- more:+-- http://hackage.haskell.org/packages/archive/TraceUtils/0.1.0.2/doc/html/Debug-TraceUtils.html+-- http://hackage.haskell.org/packages/archive/trace-call/0.1/doc/html/Debug-TraceCall.html+-- http://hackage.haskell.org/packages/archive/htrace/0.1/doc/html/Debug-HTrace.html+-- http://hackage.haskell.org/packages/archive/traced/2009.7.20/doc/html/Debug-Traced.html++module Hledger.Utils.Debug (+  module Hledger.Utils.Debug+  ,module Debug.Trace+#if __GLASGOW_HASKELL__ >= 704+  ,ppShow+#endif+)+where++import Control.Monad (when)+import Data.List+import Debug.Trace+import Safe (readDef)+import System.Environment (getArgs)+import System.Exit+import System.IO.Unsafe (unsafePerformIO)+import Text.Parsec+import Text.Printf++#if __GLASGOW_HASKELL__ >= 704+import Text.Show.Pretty (ppShow)+#else+-- the required pretty-show version requires GHC >= 7.4+ppShow :: Show a => a -> String+ppShow = show+#endif+++-- | Trace (print on stdout at runtime) a showable value.+-- (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++-- | Custom trace - like strace, with a custom show function.+traceWith :: (a -> String) -> a -> a+traceWith f e = trace (f e) e++-- | Parsec trace - show the current parsec position and next input,+-- and the provided label if it's non-null.+ptrace :: Stream [Char] m t => String -> ParsecT [Char] st m ()+ptrace msg = do+  pos <- getPosition+  next <- take peeklength `fmap` getInput+  let (l,c) = (sourceLine pos, sourceColumn pos)+      s  = printf "at line %2d col %2d: %s" l c (show next) :: String+      s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg+  trace s' $ return ()+  where+    peeklength = 30++-- | Global debug level, which controls the verbosity of debug output+-- on the console. The default is 0 meaning no debug output. The+-- @--debug@ command line flag sets it to 1, or @--debug=N@ sets it to+-- a higher value (note: not @--debug N@ for some reason).  This uses+-- unsafePerformIO and can be accessed from anywhere and before normal+-- command-line processing. After command-line processing, it is also+-- available as the @debug_@ field of 'Hledger.Cli.Options.CliOpts'.+-- {-# OPTIONS_GHC -fno-cse #-} +-- {-# NOINLINE debugLevel #-}+debugLevel :: Int+debugLevel = case snd $ break (=="--debug") args of+               "--debug":[]  -> 1+               "--debug":n:_ -> readDef 1 n+               _             ->+                 case take 1 $ filter ("--debug" `isPrefixOf`) args of+                   ['-':'-':'d':'e':'b':'u':'g':'=':v] -> readDef 1 v+                   _                                   -> 0++    where+      args = unsafePerformIO getArgs++-- | Print a message and a showable value to the console if the global+-- debug level is non-zero.  Uses unsafePerformIO.+dbg :: Show a => String -> a -> a+dbg = dbg1++-- always prints+dbg0 :: Show a => String -> a -> a+dbg0 = dbgAt 0++dbg1 :: Show a => String -> a -> a+dbg1 = dbgAt 1++dbg2 :: Show a => String -> a -> a+dbg2 = dbgAt 2++dbg3 :: Show a => String -> a -> a+dbg3 = dbgAt 3++dbg4 :: Show a => String -> a -> a+dbg4 = dbgAt 4++dbg5 :: Show a => String -> a -> a+dbg5 = dbgAt 5++dbg6 :: Show a => String -> a -> a+dbg6 = dbgAt 6++dbg7 :: Show a => String -> a -> a+dbg7 = dbgAt 7++dbg8 :: Show a => String -> a -> a+dbg8 = dbgAt 8++dbg9 :: Show a => String -> a -> a+dbg9 = dbgAt 9++-- | Print a message and a showable value to the console if the global+-- debug level is at or above the specified level.  Uses unsafePerformIO.+dbgAt :: Show a => Int -> String -> a -> a+dbgAt lvl = dbgppshow lvl++    -- Could not deduce (a ~ ())+    -- from the context (Show a)+    --   bound by the type signature for+    --              dbgM :: Show a => String -> a -> IO ()+    --   at hledger/Hledger/Cli/Main.hs:200:13-42+    --   ‘a’ is a rigid type variable bound by+    --       the type signature for dbgM :: Show a => String -> a -> IO ()+    --       at hledger/Hledger/Cli/Main.hs:200:13+    -- Expected type: String -> a -> IO ()+    --   Actual type: String -> a -> IO a+-- dbgAtM :: (Monad m, Show a) => Int -> String -> a -> m a+-- dbgAtM lvl lbl x = dbgAt lvl lbl x `seq` return x+-- XXX temporary:+dbgAtM :: Show a => Int -> String -> a -> IO ()+dbgAtM = dbgAtIO++dbgAtIO :: Show a => Int -> String -> a -> IO ()+dbgAtIO lvl lbl x = dbgAt lvl lbl x `seq` return ()++-- | print this string to the console before evaluating the expression,+-- if the global debug level is non-zero.  Uses unsafePerformIO.+dbgtrace :: String -> a -> a+dbgtrace+    | debugLevel > 0 = trace+    | otherwise      = flip const++-- | Print a showable value to the console, with a message, if the+-- debug level is at or above the specified level (uses+-- unsafePerformIO).+-- Values are displayed with show, all on one line, which is hard to read.+dbgshow :: Show a => Int -> String -> a -> a+dbgshow level+    | debugLevel >= level = ltrace+    | otherwise           = flip const++-- | Print a showable value to the console, with a message, if the+-- debug level is at or above the specified level (uses+-- unsafePerformIO).+-- Values are displayed with ppShow, each field/constructor on its own line.+dbgppshow :: Show a => Int -> String -> a -> a+dbgppshow level+    | debugLevel < level = flip const+    | otherwise = \s a -> let p = ppShow a+                              ls = lines p+                              nlorspace | length ls > 1 = "\n"+                                        | otherwise     = " " ++ take (10 - length s) (repeat ' ')+                              ls' | length ls > 1 = map (" "++) ls+                                  | otherwise     = ls+                          in trace (s++":"++nlorspace++intercalate "\n" ls') a++-- -- | Print a showable value to the console, with a message, if the+-- -- debug level is at or above the specified level (uses+-- -- unsafePerformIO).+-- -- Values are displayed with pprint. Field names are not shown, but the+-- -- output is compact with smart line wrapping, long data elided,+-- -- and slow calculations timed out.+-- dbgpprint :: Data a => Int -> String -> a -> a+-- dbgpprint level msg a+--     | debugLevel >= level = unsafePerformIO $ do+--                               pprint a >>= putStrLn . ((msg++": \n") ++) . show+--                               return a+--     | otherwise           = a+++-- | Like dbg, then exit the program. Uses unsafePerformIO.+dbgExit :: Show a => String -> a -> a+dbgExit msg = const (unsafePerformIO exitFailure) . dbg msg++-- | Print a message and parsec debug info (parse position and next+-- input) to the console when the debug level is at or above+-- this level. Uses unsafePerformIO.+-- pdbgAt :: GenParser m => Float -> String -> m ()+pdbg :: Stream [Char] m t => Int -> String -> ParsecT [Char] st m ()+pdbg level msg = when (level <= debugLevel) $ ptrace msg++

@@ -0,0 +1,139 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-|++Easy regular expression helpers, based on regex-tdfa and (a little) on+regexpr. These should:++- be cross-platform, not requiring C libraries++- support unicode++- support extended regular expressions++- support replacement, with backreferences etc.++- support splitting++- have mnemonic names++- have simple monomorphic types++- work with strings++Current limitations:++- (?i) and similar are not supported++-}++module Hledger.Utils.Regex (+   -- * type aliases+   Regexp+  ,Replacement+   -- * based on regex-tdfa+  ,regexMatches+  ,regexMatchesCI+  ,regexReplace+  ,regexReplaceCI+  ,regexReplaceBy+  ,regexReplaceByCI+   -- * based on regexpr+  ,regexSplit+  )+where++import Data.Array+import Data.Char+import Data.List (foldl')+import Text.RegexPR (splitRegexPR)+import Text.Regex.TDFA (+  Regex, CompOption(..), ExecOption(..), defaultCompOpt, defaultExecOpt,+  makeRegexOpts, AllMatches(getAllMatches), match, (=~), MatchText+  )++-- import Hledger.Utils.Debug+import Hledger.Utils.UTF8IOCompat (error')+++-- | Regular expression. Extended regular expression-ish syntax ? But does not support eg (?i) syntax.+type Regexp = String++-- | A replacement pattern. May include numeric backreferences (\N).+type Replacement = String++-- | Convert our string-based regexps to real ones. Can fail if the+-- string regexp is malformed.+toRegex :: Regexp -> Regex+toRegex = makeRegexOpts compOpt execOpt++toRegexCI :: Regexp -> Regex+toRegexCI = makeRegexOpts compOpt{caseSensitive=False} execOpt++compOpt :: CompOption+compOpt = defaultCompOpt++execOpt :: ExecOption+execOpt = defaultExecOpt++-- regexMatch' :: RegexContext Regexp String a => Regexp -> String -> a+-- regexMatch' r s = s =~ (toRegex r)++regexMatches :: Regexp -> String -> Bool+regexMatches = flip (=~)++regexMatchesCI :: Regexp -> String -> Bool+regexMatchesCI r = match (toRegexCI r)++-- | Replace all occurrences of the regexp, transforming each match with the given function.+regexReplaceBy :: Regexp -> (String -> String) -> String -> String+regexReplaceBy r = replaceAllBy (toRegex r)++regexReplaceByCI :: Regexp -> (String -> String) -> String -> String+regexReplaceByCI r = replaceAllBy (toRegexCI r)++-- | Replace all occurrences of the regexp with the replacement+-- pattern. The replacement pattern supports numeric backreferences+-- (\N) but no other RE syntax.+regexReplace :: Regexp -> Replacement -> String -> String+regexReplace re = replaceRegex (toRegex re)++regexReplaceCI :: Regexp -> Replacement -> String -> String+regexReplaceCI re = replaceRegex (toRegexCI re)++--++replaceRegex :: Regex -> Replacement -> String -> String+replaceRegex re repl s = foldl (replaceMatch repl) s (reverse $ match re s :: [MatchText String])++replaceMatch :: Replacement -> String -> MatchText String -> String+replaceMatch replpat s matchgroups = pre ++ repl ++ post+  where+    ((_,(off,len)):_) = elems matchgroups  -- groups should have 0-based indexes, and there should always be at least one, since this is a match+    (pre, post') = splitAt off s+    post = drop len post'+    repl = replaceAllBy (toRegex "\\\\[0-9]+") (replaceBackReference matchgroups) replpat++replaceBackReference :: MatchText String -> String -> String+replaceBackReference grps ('\\':s@(_:_)) | all isDigit s =+  case read s of n | n `elem` indices grps -> fst (grps ! n)+                 _                         -> error' $ "no match group exists for backreference \"\\"++s++"\""+replaceBackReference _ s = error' $ "replaceBackReference called on non-numeric-backreference \""++s++"\", shouldn't happen"++--++-- http://stackoverflow.com/questions/9071682/replacement-substition-with-haskell-regex-libraries :+-- | Replace all occurrences of a regexp in a string, transforming each match with the given function.+replaceAllBy :: Regex -> (String -> String) -> String -> String+replaceAllBy re f s = start end+  where+    (_, end, start) = foldl' go (0, s, id) $ getAllMatches $ match re s+    go (ind,read,write) (off,len) =+      let (skip, start) = splitAt (off - ind) read+          (matched, remaining) = splitAt len start+      in (off + len, remaining, write . (skip++) . (f matched ++))++-- uses regexpr, may be slow:++regexSplit :: Regexp -> String -> [Regexp]+regexSplit = splitRegexPR+

@@ -1,5 +1,5 @@ name:           hledger-lib-version: 0.23.3+version: 0.24 stability:      stable category:       Finance, Console synopsis:       Core data types, parsers and utilities for the hledger accounting tool.@@ -30,9 +30,22 @@ --   sample.ledger --   sample.timelog +source-repository head+  type:     git+  location: https://github.com/simonmichael/hledger++flag double+    Description:   Use old Double number representation (instead of Decimal), for testing/benchmarking.+    Default:       False++ library   -- should set patchlevel here as in Makefile-  cpp-options:    -DPATCHLEVEL=0+  cpp-options: -DPATCHLEVEL=0+  ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures+  ghc-options: -fno-warn-type-defaults -fno-warn-orphans+  if flag(double)+    cpp-options: -DDOUBLE   default-language: Haskell2010   exposed-modules:                   Hledger@@ -64,20 +77,25 @@                   Hledger.Reports.PostingsReport                   Hledger.Reports.TransactionsReports                   Hledger.Utils+                  Hledger.Utils.Debug+                  Hledger.Utils.Regex                   Hledger.Utils.UTF8IOCompat   build-depends:                   base >= 4.3 && < 5+                 ,array+                 ,blaze-markup >= 0.5.1                  ,bytestring                  ,cmdargs >= 0.10 && < 0.11                  ,containers                  ,csv                  -- ,data-pprint >= 0.2.3 && < 0.3+                 ,Decimal                  ,directory                  ,filepath                  ,mtl                  ,old-locale                  ,old-time-                 ,parsec+                 ,parsec >= 3                  ,regex-tdfa                  ,regexpr >= 0.5.1                  ,safe >= 0.2@@ -89,28 +107,30 @@   if impl(ghc >= 7.4)     build-depends: pretty-show >= 1.6.4 -source-repository head-  type:     git-  location: https://github.com/simonmichael/hledger  test-suite tests   type:     exitcode-stdio-1.0-  main-is:  tests/suite.hs-  ghc-options: -Wall+  main-is:  suite.hs+  hs-source-dirs: tests+  ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures+  ghc-options: -fno-warn-type-defaults -fno-warn-orphans   default-language: Haskell2010   build-depends: hledger-lib                , base >= 4.3 && < 5+               , array+               , blaze-markup >= 0.5.1                , cmdargs                , containers                , csv                -- , data-pprint >= 0.2.3 && < 0.3+               , Decimal                , directory                , filepath                , HUnit                , mtl                , old-locale                , old-time-               , parsec+               , parsec >= 3                , regex-tdfa                , regexpr                , safe