hledger-lib 0.13 → 0.14

raw patch · 19 files changed

+927/−301 lines, 19 filesdep +bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring

API changes (from Hackage documentation)

Files

• Hledger/Data.hs +14/−13
• Hledger/Data/Account.hs +3/−0
• Hledger/Data/AccountName.hs +26/−0
• Hledger/Data/Amount.hs +181/−85
• Hledger/Data/Commodity.hs +13/−9
• Hledger/Data/Dates.hs +187/−36
• Hledger/Data/Journal.hs +9/−3
• Hledger/Data/Ledger.hs +5/−0
• Hledger/Data/Posting.hs +10/−1
• Hledger/Data/TimeLog.hs +1/−1
• Hledger/Data/Transaction.hs +157/−23
• Hledger/Data/Types.hs +22/−10
• Hledger/Data/UTF8.hs +83/−0
• Hledger/Data/Utils.hs +7/−4
• Hledger/Read.hs +28/−23
• Hledger/Read/JournalReader.hs +169/−86
• Hledger/Read/TimelogReader.hs +2/−2
• Hledger/Read/Utils.hs +3/−1
• hledger-lib.cabal +7/−4

@@ -2,7 +2,8 @@  The Hledger.Data library allows parsing and querying of C++ ledger-style journal files.  It generally provides a compatible subset of C++ ledger's-functionality.  This package re-exports all the Hledger.Data.* modules.+functionality.  This package re-exports all the Hledger.Data.* modules+(except UTF8, which requires an explicit import.)  -} @@ -37,16 +38,16 @@  tests_Hledger_Data = TestList     [-    --  Hledger.Data.Account.tests_Account-    -- ,Hledger.Data.AccountName.tests_AccountName-     Hledger.Data.Amount.tests_Amount-    -- ,Hledger.Data.Commodity.tests_Commodity-    ,Hledger.Data.Dates.tests_Dates-    ,Hledger.Data.Transaction.tests_Transaction-    -- ,Hledger.Data.Hledger.Data.tests_Hledger.Data-    -- ,Hledger.Data.Journal.tests_Journal-    -- ,Hledger.Data.Posting.tests_Posting-    ,Hledger.Data.TimeLog.tests_TimeLog-    -- ,Hledger.Data.Types.tests_Types-    -- ,Hledger.Data.Utils.tests_Utils+     tests_Hledger_Data_Account+    ,tests_Hledger_Data_AccountName+    ,tests_Hledger_Data_Amount+    ,tests_Hledger_Data_Commodity+    ,tests_Hledger_Data_Dates+    ,tests_Hledger_Data_Journal+    ,tests_Hledger_Data_Ledger+    ,tests_Hledger_Data_Posting+    ,tests_Hledger_Data_TimeLog+    ,tests_Hledger_Data_Transaction+    -- ,tests_Hledger_Data_Types+    -- ,tests_Hledger_Data_Utils     ]

@@ -25,3 +25,6 @@  nullacct = Account "" [] nullmixedamt +tests_Hledger_Data_Account = TestList [+ ]+

@@ -173,3 +173,29 @@ clipAccountName :: Int -> AccountName -> AccountName clipAccountName n = accountNameFromComponents . take n . accountNameComponents +tests_Hledger_Data_AccountName = TestList+ [+  "accountNameTreeFrom" ~: do+    accountNameTreeFrom ["a"]       `is` Node "top" [Node "a" []]+    accountNameTreeFrom ["a","b"]   `is` Node "top" [Node "a" [], Node "b" []]+    accountNameTreeFrom ["a","a:b"] `is` Node "top" [Node "a" [Node "a:b" []]]+    accountNameTreeFrom ["a:b:c"]   `is` Node "top" [Node "a" [Node "a:b" [Node "a:b:c" []]]]++  ,"expandAccountNames" ~:+    expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] `is`+     ["assets","assets:cash","assets:checking","expenses","expenses:vacation"]++  ,"isAccountNamePrefixOf" ~: do+    "assets" `isAccountNamePrefixOf` "assets" `is` False+    "assets" `isAccountNamePrefixOf` "assets:bank" `is` True+    "assets" `isAccountNamePrefixOf` "assets:bank:checking" `is` True+    "my assets" `isAccountNamePrefixOf` "assets:bank" `is` False++  ,"isSubAccountNameOf" ~: do+    "assets" `isSubAccountNameOf` "assets" `is` False+    "assets:bank" `isSubAccountNameOf` "assets" `is` True+    "assets:bank:checking" `isSubAccountNameOf` "assets" `is` False+    "assets:bank" `isSubAccountNameOf` "my assets" `is` False++ ]+

@@ -38,7 +38,40 @@  -} -module Hledger.Data.Amount+-- XXX due for review/rewrite++module Hledger.Data.Amount (+                            amounts,+                            canonicaliseAmount,+                            canonicaliseMixedAmount,+                            convertMixedAmountToSimilarCommodity,+                            costOfAmount,+                            costOfMixedAmount,+                            divideAmount,+                            divideMixedAmount,+                            isNegativeMixedAmount,+                            isReallyZeroMixedAmountCost,+                            isZeroMixedAmount,+                            maxprecision,+                            maxprecisionwithpoint,+                            missingamt,+                            normaliseMixedAmount,+                            nullamt,+                            nullmixedamt,+                            punctuatethousands,+                            setAmountPrecision,+                            setMixedAmountPrecision,+                            showAmountDebug,+                            showMixedAmount,+                            showMixedAmountDebug,+                            showMixedAmountOrZero,+                            showMixedAmountOrZeroWithoutPrice,+                            showMixedAmountWithoutPrice,+                            showMixedAmountWithPrecision,+                            sumMixedAmountsPreservingHighestPrecision,+                            tests_Hledger_Data_Amount+                            -- Hledger.Data.Amount.tests_Hledger_Data_Amount+                           ) where import qualified Data.Map as Map import Data.Map (findWithDefault)@@ -56,67 +89,49 @@     abs (Amount c q p) = Amount c (abs q) p     signum (Amount c q p) = Amount c (signum q) p     fromInteger i = Amount (comm "") (fromInteger i) Nothing-    (+) = amountop (+)-    (-) = amountop (-)-    (*) = amountop (*)--instance Ord Amount where-    compare (Amount ac aq ap) (Amount bc bq bp) = compare (ac,aq,ap) (bc,bq,bp)+    (+) = similarAmountsOp (+)+    (-) = similarAmountsOp (-)+    (*) = similarAmountsOp (*)  instance Num MixedAmount where     fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing]     negate (Mixed as) = Mixed $ map negateAmountPreservingPrice as+        where negateAmountPreservingPrice a = (-a){price=price a}     (+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs     (*)    = error' "programming error, mixed amounts do not support multiplication"     abs    = error' "programming error, mixed amounts do not support abs"     signum = error' "programming error, mixed amounts do not support signum" -instance Ord MixedAmount where-    compare (Mixed as) (Mixed bs) = compare as bs--negateAmountPreservingPrice a = (-a){price=price a}---- | Apply a binary arithmetic operator to two amounts, converting to the--- second one's commodity (and display precision), discarding any price--- information. (Using the second commodity is best since sum and other--- folds start with a no-commodity amount.)-amountop :: (Double -> Double -> Double) -> Amount -> Amount -> Amount-amountop op a@(Amount _ _ _) (Amount bc bq _) = -    Amount bc (quantity (convertAmountTo bc a) `op` bq) Nothing+-- | Apply a binary arithmetic operator to two amounts, after converting+-- the first to the commodity (and display precision) of the second in a+-- simplistic way. This should be used only for two amounts in the same+-- commodity, since the conversion rate is assumed to be 1.+-- NB preserving the second commodity is preferred since sum and other+-- folds start with the no-commodity zero amount.+similarAmountsOp :: (Double -> Double -> Double) -> Amount -> Amount -> Amount+similarAmountsOp op a (Amount bc bq _) =+    Amount bc (quantity (convertAmountToSimilarCommodity bc a) `op` bq) Nothing --- | Convert an amount to the specified commodity using the appropriate--- exchange rate (which is currently always 1).-convertAmountTo :: Commodity -> Amount -> Amount-convertAmountTo c2 (Amount c1 q _) = Amount c2 (q * conversionRate c1 c2) Nothing+-- | Convert an amount to the specified commodity, assuming an exchange rate of 1.+convertAmountToSimilarCommodity :: Commodity -> Amount -> Amount+convertAmountToSimilarCommodity c (Amount _ q _) = Amount c q Nothing --- | Convert mixed amount to the specified commodity-convertMixedAmountTo :: Commodity -> MixedAmount -> Amount-convertMixedAmountTo c2 (Mixed ams) = Amount c2 total Nothing+-- | Convert a mixed amount to the specified commodity, assuming an exchange rate of 1.+convertMixedAmountToSimilarCommodity :: Commodity -> MixedAmount -> Amount+convertMixedAmountToSimilarCommodity c (Mixed as) = Amount c total Nothing     where-    total = sum . map (quantity . convertAmountTo c2) $ ams+      total = sum $ map (quantity . convertAmountToSimilarCommodity c) as --- | Convert an amount to the commodity of its saved price, if any.+-- | Convert an amount to the commodity of its saved price, if any.  Notes:+-- - price amounts must be MixedAmounts with exactly one component Amount (or there will be a runtime error)+-- - price amounts should be positive, though this is not currently enforced costOfAmount :: Amount -> Amount-costOfAmount a@(Amount _ _ Nothing) = a-costOfAmount (Amount _ q (Just price))-    | isZeroMixedAmount price = nullamt-    | otherwise = Amount pc (pq*q) Nothing-    where (Amount pc pq _) = head $ amounts price---- | Get the string representation of an amount, based on its commodity's--- display settings.-showAmount :: Amount -> String-showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = "" -- can appear in an error message-showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) _ pri) =-    case side of-      L -> printf "%s%s%s%s" sym' space quantity price-      R -> printf "%s%s%s%s" quantity space sym' price-    where-      sym' = quoteCommoditySymbolIfNeeded sym-      space = if (spaced && not (null sym')) then " " else ""-      quantity = showAmount' a-      price = case pri of (Just pamt) -> " @ " ++ showMixedAmount pamt-                          Nothing -> ""+costOfAmount a@(Amount _ q price) =+    case price of+      Nothing -> a+      Just (UnitPrice  (Mixed [Amount pc pq Nothing])) -> Amount pc (pq*q) Nothing+      Just (TotalPrice (Mixed [Amount pc pq Nothing])) -> Amount pc (pq*signum q) Nothing+      _ -> error' "costOfAmount: Malformed price encountered, programmer error"  -- | Get the string representation of an amount, based on its commodity's -- display settings except using the specified precision.@@ -129,7 +144,7 @@ -- | Get the unambiguous string representation of an amount, for debugging. showAmountDebug :: Amount -> String showAmountDebug (Amount c q pri) = printf "Amount {commodity = %s, quantity = %s, price = %s}"-                                   (show c) (show q) (maybe "" showMixedAmountDebug pri)+                                   (show c) (show q) (maybe "" showPriceDebug pri)  -- | Get the string representation of an amount, without any \@ price. showAmountWithoutPrice :: Amount -> String@@ -139,19 +154,69 @@ showAmountWithoutPriceOrCommodity :: Amount -> String showAmountWithoutPriceOrCommodity a@Amount{commodity=c} = showAmount a{commodity=c{symbol=""}, price=Nothing} +showPrice :: Price -> String+showPrice (UnitPrice pa)  = " @ "  ++ showMixedAmount pa+showPrice (TotalPrice pa) = " @@ " ++ showMixedAmount pa++showPriceDebug :: Price -> String+showPriceDebug (UnitPrice pa)  = " @ "  ++ showMixedAmountDebug pa+showPriceDebug (TotalPrice pa) = " @@ " ++ showMixedAmountDebug pa++-- | Get the string representation of an amount, based on its commodity's+-- display settings. Amounts which look like zero are rendered without sign or commodity.+showAmount :: Amount -> String+showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = "" -- can appear in an error message+showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) _ pri) =+    case side of+      L -> printf "%s%s%s%s" sym' space quantity' price+      R -> printf "%s%s%s%s" quantity' space sym' price+    where+      quantity = showamountquantity a+      displayingzero = null $ filter (`elem` "123456789") $ quantity+      (quantity',sym') | displayingzero = ("0","")+                       | otherwise      = (quantity,quoteCommoditySymbolIfNeeded sym)+      space = if (not (null sym') && spaced) then " " else ""+      price = maybe "" showPrice pri+ -- | Get the string representation of the number part of of an amount,--- using the display precision from its commodity.-showAmount' :: Amount -> String-showAmount' (Amount (Commodity {comma=comma,precision=p}) q _) = addthousandsseparators $ qstr-  where-    addthousandsseparators = if comma then punctuatethousands else id-    qstr | p == maxprecision && isint q = printf "%d" (round q::Integer)-         | p == maxprecision            = printf "%f" q+-- using the display settings from its commodity.+showamountquantity :: Amount -> String+showamountquantity (Amount (Commodity {decimalpoint=d,precision=p,separator=s,separatorpositions=spos}) q _) =+    punctuatenumber d s spos $ 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 -maxprecision = 999999+chopdotzero str = reverse $ case reverse str of+                              '0':'.':s -> s+                              s         -> s +-- | A special precision value meaning show all available digits.+maxprecision = 999998+-- | Similar, forces display of a decimal point.+maxprecisionwithpoint = 999999++-- | Replace a number string's decimal point with the specified character,+-- and add the specified digit group separators.+punctuatenumber :: Char -> Char -> [Int] -> String -> String+punctuatenumber dec sep grps str = sign ++ reverse (addseps sep (extend grps) (reverse int)) ++ frac''+    where+      (sign,num) = break isDigit str+      (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+ -- | Add thousands-separating commas to a decimal number string punctuatethousands :: String -> String punctuatethousands s =@@ -181,8 +246,7 @@ amounts :: MixedAmount -> [Amount] amounts (Mixed as) = as --- | Does this mixed amount appear to be zero - empty, or--- containing only simple amounts which appear to be zero ?+-- | Does this mixed amount appear to be zero when displayed with its given precision ? isZeroMixedAmount :: MixedAmount -> Bool isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmount @@ -202,14 +266,14 @@ isReallyZeroMixedAmountCost :: MixedAmount -> Bool isReallyZeroMixedAmountCost = isReallyZeroMixedAmount . costOfMixedAmount --- | MixedAmount derives Eq in Types.hs, but that doesn't know that we--- want $0 = EUR0 = 0. Yet we don't want to drag all this code in there.--- When zero equality is important, use this, for now; should be used--- everywhere.-mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool-mixedAmountEquals a b = amounts a' == amounts b' || (isZeroMixedAmount a' && isZeroMixedAmount b')-    where a' = normaliseMixedAmount a-          b' = normaliseMixedAmount b+-- -- | MixedAmount derives Eq in Types.hs, but that doesn't know that we+-- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code in there.+-- -- When zero equality is important, use this, for now; should be used+-- -- everywhere.+-- mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool+-- mixedAmountEquals a b = amounts a' == amounts b' || (isZeroMixedAmount a' && isZeroMixedAmount b')+--     where a' = normaliseMixedAmount a+--           b' = normaliseMixedAmount b  -- | Get the string representation of a mixed amount, showing each of -- its component amounts. NB a mixed amount can have an empty amounts@@ -256,21 +320,19 @@     | isZeroMixedAmount a = "0"     | otherwise = showMixedAmountWithoutPrice a --- | Simplify a mixed amount by combining any component amounts which have--- the same commodity and the same price. Also removes zero amounts,--- or adds a single zero amount if there are no amounts at all.+-- | Simplify a mixed amount by removing redundancy in its component amounts, as follows:+-- 1. sum amounts which have the same commodity (ignoring their price)+-- 2. remove zero amounts+-- 3. if there are no amounts at all, add a single zero amount normaliseMixedAmount :: MixedAmount -> MixedAmount normaliseMixedAmount (Mixed as) = Mixed as''     where -      as'' = map sumSamePricedAmountsPreservingPrice $ group $ sort as'-      sort = sortBy cmpsymbolandprice-      cmpsymbolandprice a1 a2 = compare (sym a1,price a1) (sym a2,price a2)-      group = groupBy samesymbolandprice -      samesymbolandprice a1 a2 = (sym a1 == sym a2) && (price a1 == price a2)+      as'' = if null nonzeros then [nullamt] else nonzeros+      (_,nonzeros) = partition (\a -> isReallyZeroAmount a && Mixed [a] /= missingamt) as'+      as' = map sumSamePricedAmountsPreservingPrice $ group $ sort as+      sort = sortBy (\a1 a2 -> compare (sym a1) (sym a2))+      group = groupBy (\a1 a2 -> sym a1 == sym a2)       sym = symbol . commodity-      as' | null nonzeros = [head $ zeros ++ [nullamt]]-          | otherwise = nonzeros-      (zeros,nonzeros) = partition isReallyZeroAmount as  -- | Set a mixed amount's commodity to the canonicalised commodity from -- the provided commodity map.@@ -338,7 +400,7 @@ amountopPreservingHighestPrecision op a@(Amount ac@Commodity{precision=ap} _ _) (Amount bc@Commodity{precision=bp} bq _) =      Amount c q Nothing     where-      q = quantity (convertAmountTo bc a) `op` bq+      q = quantity (convertAmountToSimilarCommodity bc a) `op` bq       c = if ap > bp then ac else bc -- @@ -347,6 +409,14 @@ costOfMixedAmount :: MixedAmount -> MixedAmount costOfMixedAmount (Mixed as) = Mixed $ map costOfAmount as +-- | Divide a mixed amount's quantities by some constant.+divideMixedAmount :: MixedAmount -> Double -> MixedAmount+divideMixedAmount (Mixed as) d = Mixed $ map (flip divideAmount d) as++-- | Divide an amount's quantity by some constant.+divideAmount :: Amount -> Double -> Amount+divideAmount a@Amount{quantity=q} d = a{quantity=q/d}+ -- | The empty simple amount. nullamt :: Amount nullamt = Amount unknown 0 Nothing@@ -357,13 +427,16 @@  -- | A temporary value for parsed transactions which had no amount specified. missingamt :: MixedAmount-missingamt = Mixed [Amount Commodity {symbol="AUTO",side=L,spaced=False,comma=False,precision=0} 0 Nothing]+missingamt = Mixed [Amount unknown{symbol="AUTO"} 0 Nothing]  -tests_Amount = TestList [+tests_Hledger_Data_Amount = TestList [ -   "showMixedAmount" ~: do-     showMixedAmount (Mixed [Amount dollar 0 Nothing]) `is` "$0.00"+   "showAmount" ~: do+     showAmount (dollars 0 + pounds 0) `is` "0"++  ,"showMixedAmount" ~: do+     showMixedAmount (Mixed [Amount dollar 0 Nothing]) `is` "0"      showMixedAmount (Mixed []) `is` "0"      showMixedAmount missingamt `is` "" @@ -380,6 +453,10 @@     (a1 + a3) `is` Amount (comm "$") 0 Nothing     (a2 + a3) `is` Amount (comm "$") (-2.46) Nothing     (a3 + a3) `is` Amount (comm "$") (-2.46) Nothing+    -- arithmetic with different commodities currently assumes conversion rate 1:+    let a4 = euros (-1.23)+    assertBool "" $ isZeroAmount (a1 + a4)+     sum [a2,a3] `is` Amount (comm "$") (-2.46) Nothing     sum [a3,a3] `is` Amount (comm "$") (-2.46) Nothing     sum [a1,a2,a3,-a3] `is` Amount (comm "$") 0 Nothing@@ -393,7 +470,26 @@              [Amount dollar 1.25 Nothing,               Amount dollar0 (-1) Nothing,               Amount dollar (-0.25) Nothing])-      `is` Mixed [Amount dollar 0 Nothing]+      `is` Mixed [Amount unknown 0 Nothing] +  ,"normaliseMixedAmount" ~: do+     normaliseMixedAmount (Mixed []) `is` Mixed [nullamt]+     assertBool "" $ isZeroMixedAmount $ normaliseMixedAmount (Mixed [Amount {commodity=dollar, quantity=10,    price=Nothing}+                                                                     ,Amount {commodity=dollar, quantity=10,    price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))}+                                                                     ,Amount {commodity=dollar, quantity=(-10), price=Nothing}+                                                                     ,Amount {commodity=dollar, quantity=(-10), price=Just (TotalPrice (Mixed [Amount {commodity=euro, quantity=7, price=Nothing}]))}+                                                                     ])++  ,"punctuatethousands 1" ~: punctuatethousands "" `is` ""++  ,"punctuatethousands 2" ~: punctuatethousands "1234567.8901" `is` "1,234,567.8901"++  ,"punctuatethousands 3" ~: punctuatethousands "-100" `is` "-100"++  ,"costOfAmount" ~: do+    costOfAmount (euros 1) `is` euros 1+    costOfAmount (euros 2){price=Just $ UnitPrice $ Mixed [dollars 2]} `is` dollars 4+    costOfAmount (euros 1){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars 2+    costOfAmount (euros (-1)){price=Just $ TotalPrice $ Mixed [dollars 2]} `is` dollars (-2)    ]

@@ -21,18 +21,18 @@  -- convenient amount and commodity constructors, for tests etc. -unknown = Commodity {symbol="",   side=L,spaced=False,comma=False,precision=0}-dollar  = Commodity {symbol="$",  side=L,spaced=False,comma=False,precision=2}-euro    = Commodity {symbol="EUR",side=L,spaced=False,comma=False,precision=2}-pound   = Commodity {symbol="£",  side=L,spaced=False,comma=False,precision=2}-hour    = Commodity {symbol="h",  side=R,spaced=False,comma=False,precision=1}+unknown = Commodity {symbol="", side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]}+dollar  = Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=2,separator=',',separatorpositions=[]}+euro    = Commodity {symbol="€",side=L,spaced=False,decimalpoint='.',precision=2,separator=',',separatorpositions=[]}+pound   = Commodity {symbol="£",side=L,spaced=False,decimalpoint='.',precision=2,separator=',',separatorpositions=[]}+hour    = Commodity {symbol="h",side=R,spaced=False,decimalpoint='.',precision=1,separator=',',separatorpositions=[]}  dollars n = Amount dollar n Nothing-euros n   = Amount euro n Nothing-pounds n  = Amount pound n Nothing-hours n   = Amount hour n Nothing+euros n   = Amount euro   n Nothing+pounds n  = Amount pound  n Nothing+hours n   = Amount hour   n Nothing -defaultcommodities = [dollar,  euro,  pound, hour, unknown]+defaultcommodities = [dollar, euro, pound, hour, unknown]  -- | Look up one of the hard-coded default commodities. For use in tests. comm :: String -> Commodity@@ -57,3 +57,7 @@     commoditymap = Map.fromList [(s, commoditieswithsymbol s) | s <- symbols]     commoditieswithsymbol s = filter ((s==) . symbol) cs     symbols = nub $ map symbol cs++tests_Hledger_Data_Commodity = TestList [+ ]+

@@ -18,6 +18,8 @@  -} +-- XXX fromGregorian silently clips bad dates, use fromGregorianValid instead ?+ module Hledger.Data.Dates where @@ -33,38 +35,52 @@ showDate :: Day -> String showDate = formatTime defaultTimeLocale "%C%y/%m/%d" +-- | Get the current local date. getCurrentDay :: IO Day getCurrentDay = do     t <- getZonedTime     return $ localDay (zonedTimeToLocalTime t) +-- | Get the current local year.+getCurrentYear :: IO Integer+getCurrentYear = do+  (y,_,_) <- toGregorian `fmap` getCurrentDay+  return y+ elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a elapsedSeconds t1 = realToFrac . diffUTCTime t1  -- | Split a DateSpan into one or more consecutive spans at the specified interval. splitSpan :: Interval -> DateSpan -> [DateSpan] splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing]-splitSpan NoInterval s = [s]-splitSpan Daily s      = splitspan startofday     nextday     s-splitSpan Weekly s     = splitspan startofweek    nextweek    s-splitSpan Monthly s    = splitspan startofmonth   nextmonth   s-splitSpan Quarterly s  = splitspan startofquarter nextquarter s-splitSpan Yearly s     = splitspan startofyear    nextyear    s+splitSpan NoInterval     s = [s]+splitSpan (Days n)       s = splitspan startofday     (applyN n nextday)     s+splitSpan (Weeks n)      s = splitspan startofweek    (applyN n nextweek)    s+splitSpan (Months n)     s = splitspan startofmonth   (applyN n nextmonth)   s+splitSpan (Quarters n)   s = splitspan startofquarter (applyN n nextquarter) s+splitSpan (Years n)      s = splitspan startofyear    (applyN n nextyear)    s+splitSpan (DayOfMonth n) s = splitspan (nthdayofmonthcontaining n) (applyN (n-1) nextday . nextmonth) s+splitSpan (DayOfWeek n)  s = splitspan (nthdayofweekcontaining n)  (applyN (n-1) nextday . nextweek)  s+-- splitSpan (WeekOfYear n)    s = splitspan startofweek    (applyN n nextweek)    s+-- splitSpan (MonthOfYear n)   s = splitspan startofmonth   (applyN n nextmonth)   s+-- splitSpan (QuarterOfYear n) s = splitspan startofquarter (applyN n nextquarter) s +-- Split the given span using the provided helper functions:+-- start is applied to the span's start date to get the first sub-span's start date+-- next is applied to a sub-span's start date to get the next sub-span's start date splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan] splitspan _ _ (DateSpan Nothing Nothing) = []-splitspan start next (DateSpan Nothing (Just e)) = [DateSpan (Just $ start e) (Just $ next $ start e)]-splitspan start next (DateSpan (Just b) Nothing) = [DateSpan (Just $ start b) (Just $ next $ start b)]-splitspan start next span@(DateSpan (Just b) (Just e))-    | b == e = [span]+splitspan start next (DateSpan Nothing (Just e)) = splitspan start next (DateSpan (Just $ start e) (Just $ next $ start e))+splitspan start next (DateSpan (Just s) Nothing) = splitspan start next (DateSpan (Just $ start s) (Just $ next $ start s))+splitspan start next span@(DateSpan (Just s) (Just e))+    | s == e = [span]     | otherwise = splitspan' start next span     where-      splitspan' start next (DateSpan (Just b) (Just e))-          | b >= e = []-          | otherwise = DateSpan (Just s) (Just n)-                        : splitspan' start next (DateSpan (Just n) (Just e))-          where s = start b-                n = next s+      splitspan' start next (DateSpan (Just s) (Just e))+          | s >= e = []+          | otherwise = DateSpan (Just subs) (Just sube) : splitspan' start next (DateSpan (Just sube) (Just e))+          where subs = start s+                sube = next subs       splitspan' _ _ _ = error' "won't happen, avoids warnings"  -- | Count the days in a DateSpan, or if it is open-ended return Nothing.@@ -211,6 +227,18 @@ nextyear = startofyear . addGregorianYearsClip 1 startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day +nthdayofmonthcontaining n d | d1 >= d    = d1+                            | otherwise = d2+    where d1 = addDays (fromIntegral n-1) s+          d2 = addDays (fromIntegral n-1) $ nextmonth s+          s = startofmonth d++nthdayofweekcontaining n d | d1 >= d    = d1+                           | otherwise = d2+    where d1 = addDays (fromIntegral n-1) s+          d2 = addDays (fromIntegral n-1) $ nextweek s+          s = startofweek d+ ---------------------------------------------------------------------- -- parsing @@ -398,7 +426,7 @@ intervalanddateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) intervalanddateperiodexpr rdate = do   many spacenonewline-  i <- periodexprinterval+  i <- reportinginterval   many spacenonewline   s <- periodexprdatespan rdate   return (i,s)@@ -406,7 +434,7 @@ intervalperiodexpr :: GenParser Char st (Interval, DateSpan) intervalperiodexpr = do   many spacenonewline-  i <- periodexprinterval+  i <- reportinginterval   return (i, DateSpan Nothing Nothing)  dateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan)@@ -415,19 +443,65 @@   s <- periodexprdatespan rdate   return (NoInterval, s) -periodexprinterval :: GenParser Char st Interval-periodexprinterval = -    choice $ map try [-                tryinterval "day" "daily" Daily,-                tryinterval "week" "weekly" Weekly,-                tryinterval "month" "monthly" Monthly,-                tryinterval "quarter" "quarterly" Quarterly,-                tryinterval "year" "yearly" Yearly-               ]+-- Parse a reporting interval.+reportinginterval :: GenParser Char st Interval+reportinginterval = choice' [+                       tryinterval "day"     "daily"     Days,+                       tryinterval "week"    "weekly"    Weeks,+                       tryinterval "month"   "monthly"   Months,+                       tryinterval "quarter" "quarterly" Quarters,+                       tryinterval "year"    "yearly"    Years,+                       do string "biweekly"+                          return $ Weeks 2,+                       do string "bimonthly"+                          return $ Months 2,+                       do string "every"+                          many spacenonewline+                          n <- fmap read $ many1 digit+                          thsuffix+                          many spacenonewline+                          string "day"+                          many spacenonewline+                          string "of"+                          many spacenonewline+                          string "week"+                          return $ DayOfWeek n,+                       do string "every"+                          many spacenonewline+                          n <- fmap read $ many1 digit+                          thsuffix+                          many spacenonewline+                          string "day"+                          optional $ do+                            many spacenonewline+                            string "of"+                            many spacenonewline+                            string "month"+                          return $ DayOfMonth n+                    ]     where-      tryinterval s1 s2 v = -          choice [try (string $ "every "++s1), try (string s2)] >> return v +      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 singular compact intcons =+          choice' [+           do string compact+              return $ intcons 1,+           do string "every"+              many spacenonewline+              string singular+              return $ intcons 1,+           do string "every"+              many spacenonewline+              n <- fmap read $ many1 digit+              many spacenonewline+              string plural+              return $ intcons n+           ]+          where plural = singular ++ "s"+ periodexprdatespan :: Day -> GenParser Char st DateSpan periodexprdatespan rdate = choice $ map try [                             doubledatespan rdate,@@ -470,23 +544,100 @@  nulldate = parsedate "1900/01/01" -tests_Dates = TestList [+tests_Hledger_Data_Dates = TestList+ [ -   "splitSpan" ~: do+   "parsedate" ~: do+    let date1 = parsedate "2008/11/26"+    parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1+    parsedate "2008-02-03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1++  ,"period expressions" ~: do+    let todaysdate = parsedate "2008/11/26"+    let str `gives` result = show (parsewith (periodexpr todaysdate) str) `is` ("Right " ++ result)+    "from aug to oct"           `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))"+    "aug to oct"                `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))"+    "every 3 days in aug"       `gives` "(Days 3,DateSpan (Just 2008-08-01) (Just 2008-09-01))"+    "daily from aug"            `gives` "(Days 1,DateSpan (Just 2008-08-01) Nothing)"+    "every week to 2009"        `gives` "(Weeks 1,DateSpan Nothing (Just 2009-01-01))"++  ,"splitSpan" ~: do     let gives (interval, span) = (splitSpan interval span `is`)     (NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives`      [mkdatespan "2008/01/01" "2009/01/01"]-    (Quarterly,mkdatespan "2008/01/01" "2009/01/01") `gives`+    (Quarters 1,mkdatespan "2008/01/01" "2009/01/01") `gives`      [mkdatespan "2008/01/01" "2008/04/01"      ,mkdatespan "2008/04/01" "2008/07/01"      ,mkdatespan "2008/07/01" "2008/10/01"      ,mkdatespan "2008/10/01" "2009/01/01"      ]-    (Quarterly,nulldatespan) `gives`+    (Quarters 1,nulldatespan) `gives`      [nulldatespan]-    (Daily,mkdatespan "2008/01/01" "2008/01/01") `gives`+    (Days 1,mkdatespan "2008/01/01" "2008/01/01") `gives`      [mkdatespan "2008/01/01" "2008/01/01"]-    (Quarterly,mkdatespan "2008/01/01" "2008/01/01") `gives`+    (Quarters 1,mkdatespan "2008/01/01" "2008/01/01") `gives`      [mkdatespan "2008/01/01" "2008/01/01"]+    (Months 1,mkdatespan "2008/01/01" "2008/04/01") `gives`+     [mkdatespan "2008/01/01" "2008/02/01"+     ,mkdatespan "2008/02/01" "2008/03/01"+     ,mkdatespan "2008/03/01" "2008/04/01"+     ]+    (Months 2,mkdatespan "2008/01/01" "2008/04/01") `gives`+     [mkdatespan "2008/01/01" "2008/03/01"+     ,mkdatespan "2008/03/01" "2008/05/01"+     ]+    (Weeks 1,mkdatespan "2008/01/01" "2008/01/15") `gives`+     [mkdatespan "2007/12/31" "2008/01/07"+     ,mkdatespan "2008/01/07" "2008/01/14"+     ,mkdatespan "2008/01/14" "2008/01/21"+     ]+    (Weeks 2,mkdatespan "2008/01/01" "2008/01/15") `gives`+     [mkdatespan "2007/12/31" "2008/01/14"+     ,mkdatespan "2008/01/14" "2008/01/28"+     ]+    (DayOfMonth 2,mkdatespan "2008/01/01" "2008/04/01") `gives`+     [mkdatespan "2008/01/02" "2008/02/02"+     ,mkdatespan "2008/02/02" "2008/03/02"+     ,mkdatespan "2008/03/02" "2008/04/02"+     ]+    (DayOfWeek 2,mkdatespan "2011/01/01" "2011/01/15") `gives`+     [mkdatespan "2011/01/04" "2011/01/11"+     ,mkdatespan "2011/01/11" "2011/01/18"+     ] -    ]+  ,"fixSmartDateStr" ~: do+    let gives = is . fixSmartDateStr (parsedate "2008/11/26")+    "1999-12-02"   `gives` "1999/12/02"+    "1999.12.02"   `gives` "1999/12/02"+    "1999/3/2"     `gives` "1999/03/02"+    "19990302"     `gives` "1999/03/02"+    "2008/2"       `gives` "2008/02/01"+    "0020/2"       `gives` "0020/02/01"+    "1000"         `gives` "1000/01/01"+    "4/2"          `gives` "2008/04/02"+    "2"            `gives` "2008/11/02"+    "January"      `gives` "2008/01/01"+    "feb"          `gives` "2008/02/01"+    "today"        `gives` "2008/11/26"+    "yesterday"    `gives` "2008/11/25"+    "tomorrow"     `gives` "2008/11/27"+    "this day"     `gives` "2008/11/26"+    "last day"     `gives` "2008/11/25"+    "next day"     `gives` "2008/11/27"+    "this week"    `gives` "2008/11/24" -- last monday+    "last week"    `gives` "2008/11/17" -- previous monday+    "next week"    `gives` "2008/12/01" -- next monday+    "this month"   `gives` "2008/11/01"+    "last month"   `gives` "2008/10/01"+    "next month"   `gives` "2008/12/01"+    "this quarter" `gives` "2008/10/01"+    "last quarter" `gives` "2008/07/01"+    "next quarter" `gives` "2009/01/01"+    "this year"    `gives` "2008/01/01"+    "last year"    `gives` "2007/01/01"+    "next year"    `gives` "2009/01/01"+--     "last wed"     `gives` "2008/11/19"+--     "next friday"  `gives` "2008/11/28"+--     "next january" `gives` "2009/01/01"++ ]

@@ -268,7 +268,7 @@         fixmixedamount (Mixed as) = Mixed $ map fixamount as         fixamount = fixprice         fixprice a@Amount{price=Just _} = a-        fixprice a@Amount{commodity=c} = a{price=journalHistoricalPriceFor j d c}+        fixprice a@Amount{commodity=c} = a{price=maybe Nothing (Just . UnitPrice) $ journalHistoricalPriceFor j d c}  -- | Get the price for a commodity on the specified day from the price database, if known. -- Does only one lookup step, ie will not look up the price of a price.@@ -307,8 +307,10 @@  -- | Get this amount's commodity and any commodities referenced in its price. amountCommodities :: Amount -> [Commodity]-amountCommodities Amount{commodity=c,price=Nothing} = [c]-amountCommodities Amount{commodity=c,price=Just ma} = c:(concatMap amountCommodities $ amounts ma)+amountCommodities Amount{commodity=c,price=p} =+    case p of Nothing -> [c]+              Just (UnitPrice ma)  -> c:(concatMap amountCommodities $ amounts ma)+              Just (TotalPrice ma) -> c:(concatMap amountCommodities $ amounts ma)  -- | Get all this journal's amounts, in the order parsed. journalAmounts :: Journal -> [MixedAmount]@@ -387,3 +389,7 @@       sortedps = sortBy (comparing paccount) ps       groupedps = groupBy (\p1 p2 -> paccount p1 == paccount p2) sortedps       m' = Map.fromList [(paccount $ head g, g) | g <- groupedps]++tests_Hledger_Data_Journal = TestList [+ ]+

@@ -122,3 +122,8 @@  ledgeramounts :: Ledger -> [MixedAmount] ledgeramounts = journalAmounts . journal++tests_Hledger_Data_Ledger = TestList+ [+ ]+

@@ -74,8 +74,14 @@ postingDate :: Posting -> Day postingDate p = maybe nulldate tdate $ ptransaction p +-- |Is this posting cleared? If this posting was individually marked+-- as cleared, returns True. Otherwise, return the parent+-- transaction's cleared status or, if there is no parent+-- transaction, return False. postingCleared :: Posting -> Bool-postingCleared p = maybe False tstatus $ ptransaction p+postingCleared p = if pstatus p+                    then True+                    else maybe False tstatus $ ptransaction p  -- | Does this posting fall within the given date span ? isPostingInDateSpan :: DateSpan -> Posting -> Bool@@ -90,4 +96,7 @@ postingsDateSpan [] = DateSpan Nothing Nothing postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps')     where ps' = sortBy (comparing postingDate) ps++tests_Hledger_Data_Posting = TestList [+ ] 

@@ -90,7 +90,7 @@       ps       = [Posting{pstatus=False,paccount=acctname,pamount=amount,                           pcomment="",ptype=VirtualPosting,pmetadata=[],ptransaction=Just t}] -tests_TimeLog = TestList [+tests_Hledger_Data_TimeLog = TestList [     "timeLogEntriesToTransactions" ~: do      today <- getCurrentDay

@@ -15,7 +15,7 @@ import Hledger.Data.Dates import Hledger.Data.Posting import Hledger.Data.Amount-import Hledger.Data.Commodity (dollars, dollar, unknown)+import Hledger.Data.Commodity  instance Show Transaction where show = showTransactionUnelided @@ -72,8 +72,8 @@            | otherwise = showdate (tdate t) ++ maybe "" showedate (teffectivedate t)       status = if tstatus t then " *" else ""       code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else ""-      desc = ' ' : tdescription t-      comment = if null com then "" else "  ; " ++ com where com = tcomment t+      desc = if null d then "" else " " ++ d where d = tdescription t+      comment = if null c then "" else "  ; " ++ c where c = tcomment t       showdate = printf "%-10s" . showDate       showedate = printf "=%s" . showdate       showpostings ps@@ -133,29 +133,87 @@       rsum'  = canonicaliseMixedAmount canonicalcommoditymap $ costOfMixedAmount rsum       bvsum' = canonicaliseMixedAmount canonicalcommoditymap $ costOfMixedAmount bvsum --- | Ensure that this entry is balanced, possibly auto-filling a missing--- amount first. We can auto-fill if there is just one non-virtual--- transaction without an amount. The auto-filled balance will be--- converted to cost basis if possible. If the entry can not be balanced,--- return an error message instead.+-- | Ensure this transaction is balanced, possibly inferring a missing+-- amount or a conversion price first, or return an error message.+--+-- Balancing is affected by the provided commodities' display precisions.+--+-- We can infer an amount when there are multiple real postings and+-- exactly one of them is amountless; likewise for balanced virtual+-- postings. Inferred amounts are converted to cost basis when possible.+--+-- We can infer a price when all amounts were specified and the sum of+-- real postings' amounts is exactly two non-explicitly-priced amounts in+-- different commodities; likewise for balanced virtual postings. balanceTransaction :: Maybe (Map.Map String Commodity) -> Transaction -> Either String Transaction balanceTransaction canonicalcommoditymap t@Transaction{tpostings=ps}     | length rwithoutamounts > 1 || length bvwithoutamounts > 1         = Left $ printerr "could not balance this transaction (too many missing amounts)"-    | not $ isTransactionBalanced canonicalcommoditymap t' = Left $ printerr $ nonzerobalanceerror t'-    | otherwise = Right t'+    | not $ isTransactionBalanced canonicalcommoditymap t''' = Left $ printerr $ nonzerobalanceerror t'''+    | otherwise = Right t'''     where-      rps = filter isReal ps-      bvps = filter isBalancedVirtual ps-      (rwithamounts, rwithoutamounts) = partition hasAmount rps-      (bvwithamounts, bvwithoutamounts) = partition hasAmount bvps-      t' = t{tpostings=map balance ps}+      -- maybe infer missing amounts+      (rwithamounts, rwithoutamounts)   = partition hasAmount $ realPostings t+      (bvwithamounts, bvwithoutamounts) = partition hasAmount $ balancedVirtualPostings t+      ramounts  = map pamount rwithamounts+      bvamounts = map pamount bvwithamounts+      t' = t{tpostings=map inferamount ps}           where -            balance p | not (hasAmount p) && isReal p-                          = p{pamount = (-(sum $ map pamount rwithamounts))}-                      | not (hasAmount p) && isBalancedVirtual p-                          = p{pamount = (-(sum $ map pamount bvwithamounts))}-                      | otherwise = p+            inferamount p | not (hasAmount p) && isReal p            = p{pamount = (- sum ramounts)}+                          | not (hasAmount p) && isBalancedVirtual p = p{pamount = (- sum bvamounts)}+                          | otherwise                             = p++      -- maybe infer conversion prices, for real postings+      rmixedamountsinorder = map pamount $ realPostings t'+      ramountsinorder = concatMap amounts rmixedamountsinorder+      rcommoditiesinorder  = map commodity ramountsinorder+      rsumamounts  = amounts $ sum rmixedamountsinorder+      -- assumption: the sum of mixed amounts is normalised (one simple amount per commodity)+      t'' = if length rsumamounts == 2 && all (isNothing.price) rsumamounts && t'==t+             then t'{tpostings=map inferprice ps}+             else t'+          where+            -- assumption: a posting's mixed amount contains one simple amount+            inferprice p@Posting{pamount=Mixed [a@Amount{commodity=c,price=Nothing}], ptype=RegularPosting}+                = p{pamount=Mixed [a{price=conversionprice c}]}+                where+                  conversionprice c | c == unpricedcommodity+                                        -- assign a balancing price. Use @@ for more exact output when possible.+                                        = if length ramountsinunpricedcommodity == 1+                                           then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ negate $ targetcommodityamount]+                                           else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ negate $ targetcommodityamount `divideAmount` (quantity unpricedamount)]+                                    | otherwise = Nothing+                      where+                        unpricedcommodity     = head $ filter (`elem` (map commodity rsumamounts)) rcommoditiesinorder+                        unpricedamount        = head $ filter ((==unpricedcommodity).commodity) rsumamounts+                        targetcommodityamount = head $ filter ((/=unpricedcommodity).commodity) rsumamounts+                        ramountsinunpricedcommodity = filter ((==unpricedcommodity).commodity) ramountsinorder+            inferprice p = p++      -- maybe infer prices for balanced virtual postings. Just duplicates the above for now.+      bvmixedamountsinorder = map pamount $ balancedVirtualPostings t''+      bvamountsinorder = concatMap amounts bvmixedamountsinorder+      bvcommoditiesinorder  = map commodity bvamountsinorder+      bvsumamounts  = amounts $ sum bvmixedamountsinorder+      t''' = if length bvsumamounts == 2 && all (isNothing.price) bvsumamounts && t'==t -- XXX could check specifically for bv amount inferring+             then t''{tpostings=map inferprice ps}+             else t''+          where+            inferprice p@Posting{pamount=Mixed [a@Amount{commodity=c,price=Nothing}], ptype=BalancedVirtualPosting}+                = p{pamount=Mixed [a{price=conversionprice c}]}+                where+                  conversionprice c | c == unpricedcommodity+                                        = if length bvamountsinunpricedcommodity == 1+                                           then Just $ TotalPrice $ Mixed [setAmountPrecision maxprecision $ negate $ targetcommodityamount]+                                           else Just $ UnitPrice $ Mixed [setAmountPrecision maxprecision $ negate $ targetcommodityamount `divideAmount` (quantity unpricedamount)]+                                    | otherwise = Nothing+                      where+                        unpricedcommodity     = head $ filter (`elem` (map commodity bvsumamounts)) bvcommoditiesinorder+                        unpricedamount        = head $ filter ((==unpricedcommodity).commodity) bvsumamounts+                        targetcommodityamount = head $ filter ((/=unpricedcommodity).commodity) bvsumamounts+                        bvamountsinunpricedcommodity = filter ((==unpricedcommodity).commodity) bvamountsinorder+            inferprice p = p+       printerr s = intercalate "\n" [s, showTransactionUnelided t]  nonzerobalanceerror :: Transaction -> String@@ -172,7 +230,6 @@ journalTransactionWithDate :: WhichDate -> Transaction -> Transaction journalTransactionWithDate ActualDate t = t journalTransactionWithDate EffectiveDate t = txnTieKnot t{tdate=fromMaybe (tdate t) (teffectivedate t)}-      -- | Ensure a transaction's postings refer back to it. txnTieKnot :: Transaction -> Transaction@@ -182,7 +239,7 @@ settxn :: Transaction -> Posting -> Posting settxn t p = p{ptransaction=Just t} -tests_Transaction = TestList [+tests_Hledger_Data_Transaction = TestList [   "showTransaction" ~: do      assertEqual "show a balanced transaction, eliding last amount"        (unlines@@ -260,8 +317,85 @@         ])        (showTransaction         (txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" []-         [Posting False "a" (Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])]) "" RegularPosting [] Nothing+         [Posting False "a" (Mixed [Amount unknown 1 (Just $ UnitPrice $ Mixed [Amount dollar{precision=0} 2 Nothing])]) "" RegularPosting [] Nothing          ,Posting False "b" missingamt "" RegularPosting [] Nothing          ] ""))++  ,"balanceTransaction" ~: do+     assertBool "detect unbalanced entry, sign error"+                    (isLeft $ balanceTransaction Nothing+                           (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" []+                            [Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing,+                             Posting False "b" (Mixed [dollars 1]) "" RegularPosting [] Nothing+                            ] ""))+     assertBool "detect unbalanced entry, multiple missing amounts"+                    (isLeft $ balanceTransaction Nothing+                           (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" []+                            [Posting False "a" missingamt "" RegularPosting [] Nothing,+                             Posting False "b" missingamt "" RegularPosting [] Nothing+                            ] ""))+     let e = balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "" "" []+                           [Posting False "a" (Mixed [dollars 1]) "" RegularPosting [] Nothing,+                            Posting False "b" missingamt "" RegularPosting [] Nothing+                           ] "")+     assertBool "balanceTransaction allows one missing amount" (isRight e)+     assertEqual "balancing amount is inferred"+                     (Mixed [dollars (-1)])+                     (case e of+                        Right e' -> (pamount $ last $ tpostings e')+                        Left _ -> error' "should not happen")+     let e = balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" []+                           [Posting False "a" (Mixed [dollars 1.35]) "" RegularPosting [] Nothing,+                            Posting False "b" (Mixed [euros   (-1)]) "" RegularPosting [] Nothing+                           ] "")+     assertBool "balanceTransaction can infer conversion price" (isRight e)+     assertEqual "balancing conversion price is inferred"+                     (Mixed [Amount{commodity=dollar{precision=2},+                                    quantity=1.35,+                                    price=(Just $ TotalPrice $ Mixed [Amount{commodity=euro{precision=maxprecision},+                                                                             quantity=1,+                                                                             price=Nothing}])}])+                     (case e of+                        Right e' -> (pamount $ head $ tpostings e')+                        Left _ -> error' "should not happen")++  ,"isTransactionBalanced" ~: do+     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []+             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)+             ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t)+             ] ""+     assertBool "detect balanced" (isTransactionBalanced Nothing t)+     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []+             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)+             ,Posting False "c" (Mixed [dollars (-1.01)]) "" RegularPosting [] (Just t)+             ] ""+     assertBool "detect unbalanced" (not $ isTransactionBalanced Nothing t)+     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []+             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)+             ] ""+     assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced Nothing t)+     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []+             [Posting False "b" (Mixed [dollars 0]) "" RegularPosting [] (Just t)+             ] ""+     assertBool "one zero posting is considered balanced for now" (isTransactionBalanced Nothing t)+     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []+             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)+             ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t)+             ,Posting False "d" (Mixed [dollars 100]) "" VirtualPosting [] (Just t)+             ] ""+     assertBool "virtual postings don't need to balance" (isTransactionBalanced Nothing t)+     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" []+             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)+             ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t)+             ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting [] (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" "" []+             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting [] (Just t)+             ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting [] (Just t)+             ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting [] (Just t)+             ,Posting False "e" (Mixed [dollars (-100)]) "" BalancedVirtualPosting [] (Just t)+             ] ""+     assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced Nothing t)    ]

@@ -46,7 +46,10 @@  data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord) -data Interval = NoInterval | Daily | Weekly | Monthly | Quarterly | Yearly +data Interval = NoInterval+              | Days Int | Weeks Int | Months Int | Quarters Int | Years Int+              | DayOfMonth Int | DayOfWeek Int+              -- WeekOfYear Int | MonthOfYear Int | QuarterOfYear Int                 deriving (Eq,Show,Ord)  type AccountName = String@@ -54,21 +57,30 @@ data Side = L | R deriving (Eq,Show,Read,Ord)  data Commodity = Commodity {-      symbol :: String,  -- ^ the commodity's symbol+      symbol :: String,            -- ^ the commodity's symbol       -- display preferences for amounts of this commodity-      side :: Side,      -- ^ should the symbol appear on the left or the right-      spaced :: Bool,    -- ^ should there be a space between symbol and quantity-      comma :: Bool,     -- ^ should thousands be comma-separated-      precision :: Int   -- ^ number of decimal places to display-    } deriving (Eq,Show,Read,Ord)+      side :: Side,                -- ^ should the symbol appear on the left or the right+      spaced :: Bool,              -- ^ should there be a space between symbol and quantity+      precision :: Int,            -- ^ number of decimal places to display+      -- XXX these three might be better belonging to Journal+      decimalpoint :: Char,        -- ^ character to use as decimal point+      separator :: Char,           -- ^ character to use for separating digit groups (eg thousands)+      separatorpositions :: [Int]  -- ^ positions of separators, counting leftward from decimal point+    } deriving (Eq,Ord,Show,Read) +-- | An amount's price may be written as \@ unit price or \@\@ total price.+-- Note although Price has a MixedAmount, it should hold only+-- single-commodity amounts, cf costOfAmount.+data Price = UnitPrice MixedAmount | TotalPrice MixedAmount+             deriving (Eq,Ord)+ data Amount = Amount {       commodity :: Commodity,       quantity :: Double,-      price :: Maybe MixedAmount  -- ^ unit price/conversion rate for this amount at posting time-    } deriving (Eq)+      price :: Maybe Price  -- ^ the price for this amount at posting time+    } deriving (Eq,Ord) -newtype MixedAmount = Mixed [Amount] deriving (Eq)+newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord)  data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting                    deriving (Eq,Show)

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

@@ -19,6 +19,7 @@ module Data.Time.LocalTime, module Debug.Trace, module Hledger.Data.Utils,+-- module Hledger.Data.UTF8, module Text.Printf, module Text.RegexPR, module Test.HUnit,@@ -36,10 +37,9 @@ import Data.Time.Calendar import Data.Time.LocalTime import Debug.Trace-#if __GLASGOW_HASKELL__ <= 610-import Prelude hiding (readFile,putStr,print)-import System.IO.UTF8-#endif+-- needs to be done in each module I think+-- import Prelude hiding (readFile,writeFile,getContents,putStr,putStrLn)+-- import Hledger.Data.UTF8 import Test.HUnit import Text.Printf import Text.RegexPR@@ -371,3 +371,6 @@ -- --                                return (homeDirectory pw ++ path) -- tildeExpand xs           =  return xs +-- | Apply a function the specified number of times. Possibly uses O(n) stack ?+applyN :: Int -> (a -> a) -> a -> a+applyN n f = (!! n) . iterate f

@@ -16,13 +16,6 @@        myTimelog, ) where-import Hledger.Data.Dates (getCurrentDay)-import Hledger.Data.Types (Journal(..), Reader(..))-import Hledger.Data.Journal (nullctx)-import Hledger.Data.Utils-import Hledger.Read.JournalReader as JournalReader-import Hledger.Read.TimelogReader as TimelogReader- import Control.Monad.Error import Data.Either (partitionEithers) import Safe (headDef)@@ -30,18 +23,22 @@ import System.Environment (getEnv) import System.FilePath ((</>)) import System.IO (IOMode(..), withFile, stderr)-#if __GLASGOW_HASKELL__ <= 610++import Hledger.Data.Dates (getCurrentDay)+import Hledger.Data.Types (Journal(..), Reader(..))+import Hledger.Data.Journal (nullctx)+import Hledger.Data.Utils import Prelude hiding (getContents)-import System.IO.UTF8 (getContents, hGetContents)-#else-import System.IO (hGetContents)-#endif+import Hledger.Data.UTF8 (getContents, hGetContents)+import Hledger.Read.JournalReader as JournalReader+import Hledger.Read.TimelogReader as TimelogReader  -journalenvvar           = "LEDGER"-timelogenvvar          = "TIMELOG"-journaldefaultfilename  = ".journal"-timelogdefaultfilename = ".timelog"+journalenvvar           = "LEDGER_FILE"+journalenvvar2          = "LEDGER"+timelogenvvar           = "TIMELOG"+journaldefaultfilename  = ".hledger.journal"+timelogdefaultfilename = ".hledger.timelog"  -- Here are the available readers. The first is the default, used for unknown data formats. readers :: [Reader]@@ -111,13 +108,21 @@ readJournal :: Maybe String -> String -> IO (Either String Journal) readJournal format s = journalFromPathAndString format "(string)" s --- | Get the user's default journal file path.+-- | Get the user's journal file path. Like ledger, we look first for the+-- LEDGER_FILE environment variable, and if that does not exist, for the+-- legacy LEDGER environment variable. If neither is set, or the value is+-- blank, return the default journal file path, which is+-- ".hledger.journal" in the users's home directory, or if we cannot+-- determine that, in the current directory. myJournalPath :: IO String-myJournalPath =-    getEnv journalenvvar `catch`-               (\_ -> do+myJournalPath = do+  s <- envJournalPath+  if null s then defaultJournalPath else return s+    where+      envJournalPath = getEnv journalenvvar `catch` (\_ -> getEnv journalenvvar2 `catch` (\_ -> return ""))+      defaultJournalPath = do                   home <- getHomeDirectory `catch` (\_ -> return "")-                  return $ home </> journaldefaultfilename)+                  return $ home </> journaldefaultfilename    -- | Get the user's default timelog file path. myTimelogPath :: IO String@@ -137,12 +142,12 @@  tests_Hledger_Read = TestList   [+   tests_Hledger_Read_JournalReader,+   tests_Hledger_Read_TimelogReader,     "journalFile" ~: do     assertBool "journalFile should parse an empty file" (isRight $ parseWithCtx nullctx JournalReader.journalFile "")     jE <- readJournal Nothing "" -- don't know how to get it from journalFile     either error' (assertBool "journalFile parsing an empty file should give an empty journal" . null . jtxns) jE -  ,JournalReader.tests_JournalReader-  ,TimelogReader.tests_TimelogReader   ]

@@ -104,28 +104,27 @@ -}  module Hledger.Read.JournalReader (-       tests_JournalReader,-       reader,-       journalFile,+       emptyLine,        journalAddFile,-       someamount,+       journalFile,        ledgeraccountname,+       ledgerdatetime,+       ledgerDefaultYear,        ledgerExclamationDirective,        ledgerHistoricalPrice,-       ledgerDefaultYear,-       emptyLine,-       ledgerdatetime,+       reader,+       someamount,+       tests_Hledger_Read_JournalReader ) where import Control.Monad.Error (ErrorT(..), throwError, catchError) import Data.List.Split (wordsBy)+import Safe (headDef) import Text.ParserCombinators.Parsec hiding (parse)-#if __GLASGOW_HASKELL__ <= 610-import Prelude hiding (readFile, putStr, putStrLn, print, getContents)-import System.IO.UTF8-#endif  import Hledger.Data+import Prelude hiding (readFile)+import Hledger.Data.UTF8 (readFile) import Hledger.Read.Utils  @@ -318,8 +317,7 @@   restofline   return $ return id --- | Try to parse a ledger entry. If we successfully parse an entry,--- check it can be balanced, and fail if not.+-- | Parse a (possibly unbalanced) ledger transaction. ledgerTransaction :: GenParser Char JournalContext Transaction ledgerTransaction = do   date <- ledgerdate <?> "transaction"@@ -332,12 +330,7 @@       ) <?> "description and/or comment"   md <- try ledgermetadata <|> return []   postings <- ledgerpostings-  let t = txnTieKnot $ Transaction date edate status code description comment md postings ""-  -- case balanceTransaction Nothing t of-  --   Right t' -> return t'-  --   Left err -> fail err-  -- check it later, after we have worked out commodity display precisions-  return t+  return $ txnTieKnot $ Transaction date edate status code description comment md postings ""  ledgerdate :: GenParser Char JournalContext Day ledgerdate = do@@ -346,20 +339,15 @@   -- pos <- getPosition   datestr <- many1 $ choice' [digit, datesepchar]   let dateparts = wordsBy (`elem` datesepchars) datestr-  case dateparts of-    [y,m,d] -> do-               failIfInvalidYear y-               failIfInvalidMonth m-               failIfInvalidDay d-               return $ fromGregorian (read y) (read m) (read d)-    [m,d]   -> do-               y <- getYear-               case y of Nothing -> fail "partial date found, but no default year specified"-                         Just y' -> do failIfInvalidYear $ show y'-                                       failIfInvalidMonth m-                                       failIfInvalidDay d-                                       return $ fromGregorian y' (read m) (read d)-    _       -> fail $ "bad date: " ++ datestr+  currentyear <- getYear+  let [y,m,d] = case (dateparts,currentyear) of+                  ([m,d],Just y)  -> [show y,m,d]+                  ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"+                  _               -> dateparts+      maybedate = fromGregorianValid (read y) (read m) (read d)+  case maybedate of+    Nothing   -> fail $ "bad date: " ++ datestr+    Just date -> return date   <?> "full or partial date"  ledgerdatetime :: GenParser Char JournalContext LocalTime@@ -423,6 +411,7 @@   ls <- many1 $ try linebeginningwithspaces   let parses p = isRight . parseWithCtx ctx p       postinglines = filter (not . (ledgercommentline `parses`)) ls+      -- group any metadata lines with the posting line above       postinglinegroups :: [String] -> [String]       postinglinegroups [] = []       postinglinegroups (pline:ls) = (unlines $ pline:mdlines):postinglinegroups rest@@ -494,28 +483,28 @@   let applysign = if isJust sign then negate else id   sym <- commoditysymbol    sp <- many spacenonewline-  (q,p,comma) <- amountquantity+  (q,p,d,s,spos) <- number   pri <- priceamount-  let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,comma=comma,precision=p}+  let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,decimalpoint=d,precision=p,separator=s,separatorpositions=spos}   return $ applysign $ Mixed [Amount c q pri]   <?> "left-symbol amount"  rightsymbolamount :: GenParser Char JournalContext MixedAmount rightsymbolamount = do-  (q,p,comma) <- amountquantity+  (q,p,d,s,spos) <- number   sp <- many spacenonewline   sym <- commoditysymbol   pri <- priceamount-  let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,comma=comma,precision=p}+  let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,decimalpoint=d,precision=p,separator=s,separatorpositions=spos}   return $ Mixed [Amount c q pri]   <?> "right-symbol amount"  nosymbolamount :: GenParser Char JournalContext MixedAmount nosymbolamount = do-  (q,p,comma) <- amountquantity+  (q,p,d,s,spos) <- number   pri <- priceamount   defc <- getCommodity-  let c = fromMaybe Commodity{symbol="",side=L,spaced=False,comma=comma,precision=p} defc+  let c = fromMaybe Commodity{symbol="",side=L,spaced=False,decimalpoint=d,precision=p,separator=s,separatorpositions=spos} defc   return $ Mixed [Amount c q pri]   <?> "no-symbol amount" @@ -532,60 +521,138 @@ simplecommoditysymbol :: GenParser Char JournalContext String simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars) -priceamount :: GenParser Char JournalContext (Maybe MixedAmount)+priceamount :: GenParser Char JournalContext (Maybe Price) priceamount =     try (do           many spacenonewline           char '@'-          many spacenonewline-          a <- someamount -- XXX could parse more prices ad infinitum, shouldn't-          return $ Just a-          ) <|> return Nothing+          try (do+                char '@'+                many spacenonewline+                a <- someamount -- XXX can parse more prices ad infinitum, shouldn't+                return $ Just $ TotalPrice a)+           <|> (do+            many spacenonewline+            a <- someamount -- XXX can parse more prices ad infinitum, shouldn't+            return $ Just $ UnitPrice a))+         <|> return Nothing  -- gawd.. trying to parse a ledger number without error: --- | Parse a ledger-style numeric quantity and also return the number of--- digits to the right of the decimal point and whether thousands are--- separated by comma.-amountquantity :: GenParser Char JournalContext (Double, Int, Bool)-amountquantity = do-  sign <- optionMaybe $ string "-"-  (intwithcommas,frac) <- numberparts-  let comma = ',' `elem` intwithcommas-  let precision = length frac-  -- read the actual value. We expect this read to never fail.-  let int = filter (/= ',') intwithcommas-  let int' = if null int then "0" else int-  let frac' = if null frac then "0" else frac-  let sign' = fromMaybe "" sign-  let quantity = read $ sign'++int'++"."++frac'-  return (quantity, precision, comma)-  <?> "commodity quantity"+type Quantity = Double --- | parse the two strings of digits before and after a possible decimal--- point.  The integer part may contain commas, or either part may be--- empty, or there may be no point.-numberparts :: GenParser Char JournalContext (String,String)-numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint+-- -- | Parse a ledger-style numeric quantity and also return the number of+-- -- digits to the right of the decimal point and whether thousands are+-- -- separated by comma.+-- amountquantity :: GenParser Char JournalContext (Quantity, Int, Bool)+-- amountquantity = do+--   sign <- optionMaybe $ string "-"+--   (intwithcommas,frac) <- numberparts+--   let comma = ',' `elem` intwithcommas+--   let precision = length frac+--   -- read the actual value. We expect this read to never fail.+--   let int = filter (/= ',') intwithcommas+--   let int' = if null int then "0" else int+--   let frac' = if null frac then "0" else frac+--   let sign' = fromMaybe "" sign+--   let quantity = read $ sign'++int'++"."++frac'+--   return (quantity, precision, comma)+--   <?> "commodity quantity" -numberpartsstartingwithdigit :: GenParser Char JournalContext (String,String)-numberpartsstartingwithdigit = do-  let digitorcomma = digit <|> char ','-  first <- digit-  rest <- many digitorcomma-  frac <- try (do {char '.'; many digit}) <|> return ""-  return (first:rest,frac)-                     -numberpartsstartingwithpoint :: GenParser Char JournalContext (String,String)-numberpartsstartingwithpoint = do-  char '.'-  frac <- many1 digit-  return ("",frac)+-- -- | parse the two strings of digits before and after a possible decimal+-- -- point.  The integer part may contain commas, or either part may be+-- -- empty, or there may be no point.+-- numberparts :: GenParser Char JournalContext (String,String)+-- numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint++-- numberpartsstartingwithdigit :: GenParser Char JournalContext (String,String)+-- numberpartsstartingwithdigit = do+--   let digitorcomma = digit <|> char ','+--   first <- digit+--   rest <- many digitorcomma+--   frac <- try (do {char '.'; many digit}) <|> return ""+--   return (first:rest,frac)                      +-- numberpartsstartingwithpoint :: GenParser Char JournalContext (String,String)+-- numberpartsstartingwithpoint = do+--   char '.'+--   frac <- many1 digit+--   return ("",frac) -tests_JournalReader = TestList [+-- | 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).+number :: GenParser Char JournalContext (Quantity, Int, Char, Char, [Int])+number = do+  sign <- optionMaybe $ string "-"+  parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.']+  let numeric = isNumber . headDef '_'+      (_, puncparts) = partition numeric parts+      (ok,decimalpoint',separator') =+          case puncparts of+            []     -> (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+  when (not ok) (fail $ "number seems ill-formed: "++concat parts)+  let (intparts',fracparts') = span ((/= decimalpoint') . Just . head) parts+      (intparts, fracpart) = (filter numeric intparts', filter numeric fracparts')+      separatorpositions = reverse $ map length $ drop 1 intparts+      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+      sign' = fromMaybe "" sign+      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)+  <?> "number" -   "ledgerTransaction" ~: do+tests_Hledger_Read_JournalReader = TestList [++    "number" ~: do+      let s `is` n = assertParseEqual (parseWithCtx nullctx number s) n+          assertFails = assertBool "" . isLeft . parseWithCtx nullctx number +      assertFails ""+      "0"          `is` (0, 0, '.', ',', [])+      "1"          `is` (1, 0, '.', ',', [])+      "1.1"        `is` (1.1, 1, '.', ',', [])+      "1,000.1"    `is` (1000.1, 1, '.', ',', [3])+      "1.00.000,1" `is` (100000.1, 1, ',', '.', [3,2])+      "1,000,000"  `is` (1000000, 0, '.', ',', [3,3])+      "1."         `is` (1,   0, '.', ',', [])+      "1,"         `is` (1,   0, ',', '.', [])+      ".1"         `is` (0.1, 1, '.', ',', [])+      ",1"         `is` (0.1, 1, ',', '.', [])+      assertFails "1,000.000,1"+      assertFails "1.000,000.1"+      assertFails "1,000.000.1"+      assertFails "1,,1"+      assertFails "1..1"+      assertFails ".1,"+      assertFails ",1."++   ,"ledgerTransaction" ~: do     assertParseEqual (parseWithCtx nullctx ledgerTransaction entry1_str) entry1     assertBool "ledgerTransaction should not parse just a date"                    $ isLeft $ parseWithCtx nullctx ledgerTransaction "2009/1/1\n"@@ -650,20 +717,36 @@          assertMixedAmountParse parseresult mixedamount =              (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount)      assertMixedAmountParse (parseWithCtx nullctx someamount "1 @ $2")-                            (Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])])+                            (Mixed [Amount unknown 1 (Just $ UnitPrice $ Mixed [Amount dollar{precision=0} 2 Nothing])])    ,"postingamount" ~: do     assertParseEqual (parseWithCtx nullctx postingamount " $47.18") (Mixed [dollars 47.18])     assertParseEqual (parseWithCtx nullctx postingamount " $1.")-                (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing])+                (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} 1 Nothing])+  ,"postingamount with unit price" ~: do+    assertParseEqual+     (parseWithCtx nullctx postingamount " $10 @ €0.5")+     (Mixed [Amount{commodity=dollar{precision=0},+                    quantity=10,+                    price=(Just $ UnitPrice $ Mixed [Amount{commodity=euro{precision=1},+                                                            quantity=0.5,+                                                            price=Nothing}])}])+  ,"postingamount with total price" ~: do+    assertParseEqual+     (parseWithCtx nullctx postingamount " $10 @@ €5")+     (Mixed [Amount{commodity=dollar{precision=0},+                    quantity=10,+                    price=(Just $ TotalPrice $ Mixed [Amount{commodity=euro{precision=0},+                                                             quantity=5,+                                                             price=Nothing}])}])    ,"leftsymbolamount" ~: do     assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1")-                     (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing])+                     (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} 1 Nothing])     assertParseEqual (parseWithCtx nullctx leftsymbolamount "$-1")-                     (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} (-1) Nothing])+                     (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} (-1) Nothing])     assertParseEqual (parseWithCtx nullctx leftsymbolamount "-$1")-                     (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} (-1) Nothing])+                     (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} (-1) Nothing])   ] 

@@ -43,8 +43,8 @@ -}  module Hledger.Read.TimelogReader (-       tests_TimelogReader,        reader,+       tests_Hledger_Read_TimelogReader ) where import Control.Monad.Error (ErrorT(..))@@ -96,6 +96,6 @@   comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline)   return $ TimeLogEntry (read [code]) datetime (maybe "" rstrip comment) -tests_TimelogReader = TestList [+tests_Hledger_Read_TimelogReader = TestList [  ] 

@@ -13,6 +13,7 @@  import Hledger.Data.Types (Journal, JournalContext(..), Commodity, JournalUpdate) import Hledger.Data.Utils+import Hledger.Data.Dates (getCurrentYear) import Hledger.Data.Journal (nullctx, nulljournal, journalFinalise)  @@ -25,7 +26,8 @@ parseJournalWith p f s = do   tc <- liftIO getClockTime   tl <- liftIO getCurrentLocalTime-  case runParser p nullctx f s of+  y <- liftIO getCurrentYear+  case runParser p nullctx{ctxYear=Just y} f s of     Right (updates,ctx) -> do                            j <- updates `ap` return nulljournal                            case journalFinalise tc tl f s ctx j of

@@ -1,10 +1,11 @@ name:           hledger-lib-version: 0.13+version: 0.14 category:       Finance-synopsis:       Core types and utilities for working with hledger (or c++ ledger) data.+synopsis:       Reusable types and utilities for the hledger accounting tool and financial apps in general. description:-                This is the reusable core of the hledger financial app; use it to-                build hledger and c++-ledger compatible finance tools.+                hledger is a haskell port and friendly fork of John Wiegley's ledger accounting tool.+                This package provides core data types, parsers and utilities used by the hledger tools.+                It also aims to be a useful library for building h/ledger-compatible tools or unrelated financial apps in haskell.  license:        GPL license-file:   LICENSE@@ -41,12 +42,14 @@                   Hledger.Data.TimeLog                   Hledger.Data.Types                   Hledger.Data.Utils+                  Hledger.Data.UTF8                   Hledger.Read                   Hledger.Read.Utils                   Hledger.Read.JournalReader                   Hledger.Read.TimelogReader   Build-Depends:                   base >= 3 && < 5+                 ,bytestring                  ,containers                  ,directory                  ,filepath