hledger-lib 0.17 → 0.18

raw patch · 25 files changed

+3636/−1473 lines, 25 filesdep +csvdep +shakespeare-textPVP ok

version bump matches the API change (PVP)

Dependencies added: csv, shakespeare-text

API changes (from Hackage documentation)

Files

• Hledger.hs +14/−1
• Hledger/Data.hs +0/−3
• Hledger/Data/Account.hs +1/−1
• Hledger/Data/AccountName.hs +1/−1
• Hledger/Data/Amount.hs +35/−19
• Hledger/Data/Dates.hs +71/−28
• Hledger/Data/FormatStrings.hs +118/−0
• Hledger/Data/Journal.hs +535/−74
• Hledger/Data/Ledger.hs +30/−69
• Hledger/Data/Matching.hs +0/−324
• Hledger/Data/Posting.hs +63/−12
• Hledger/Data/TimeLog.hs +2/−2
• Hledger/Data/Transaction.hs +144/−36
• Hledger/Data/Types.hs +81/−24
• Hledger/Query.hs +574/−0
• Hledger/Read.hs +156/−86
• Hledger/Read/CsvReader.hs +584/−0
• Hledger/Read/JournalReader.hs +486/−423
• Hledger/Read/TimelogReader.hs +26/−21
• Hledger/Read/Utils.hs +0/−86
• Hledger/Reports.hs +539/−115
• Hledger/Utils.hs +44/−54
• Hledger/Utils/UTF8.hs +0/−87
• Hledger/Utils/UTF8IOCompat.hs +122/−0
• hledger-lib.cabal +10/−7

@@ -1,11 +1,24 @@ module Hledger (                 module Hledger.Data+               ,module Hledger.Query                ,module Hledger.Read                ,module Hledger.Reports                ,module Hledger.Utils+               ,tests_Hledger ) where+import Test.HUnit+ import Hledger.Data-import Hledger.Read+import Hledger.Query+import Hledger.Read hiding (samplejournal) import Hledger.Reports import Hledger.Utils++tests_Hledger = TestList+    [+     tests_Hledger_Data+    ,tests_Hledger_Query+    ,tests_Hledger_Read+    ,tests_Hledger_Reports+    ]

@@ -15,7 +15,6 @@                module Hledger.Data.Dates,                module Hledger.Data.Journal,                module Hledger.Data.Ledger,-               module Hledger.Data.Matching,                module Hledger.Data.Posting,                module Hledger.Data.TimeLog,                module Hledger.Data.Transaction,@@ -32,7 +31,6 @@ import Hledger.Data.Dates import Hledger.Data.Journal import Hledger.Data.Ledger-import Hledger.Data.Matching import Hledger.Data.Posting import Hledger.Data.TimeLog import Hledger.Data.Transaction@@ -47,7 +45,6 @@     ,tests_Hledger_Data_Dates     ,tests_Hledger_Data_Journal     ,tests_Hledger_Data_Ledger-    ,tests_Hledger_Data_Matching     ,tests_Hledger_Data_Posting     ,tests_Hledger_Data_TimeLog     ,tests_Hledger_Data_Transaction

@@ -20,7 +20,7 @@   instance Show Account where-    show (Account a ts b) = printf "Account %s with %d txns and %s balance" a (length ts) (showMixedAmount b)+    show (Account a ps b) = printf "Account %s with %d postings and %s balance" a (length ps) (showMixedAmountDebug b)  instance Eq Account where     (==) (Account n1 t1 b1) (Account n2 t2 b2) = n1 == n2 && t1 == t2 && b1 == b2

@@ -183,7 +183,7 @@ accountNameToAccountRegex "" = "" accountNameToAccountRegex a = printf "^%s(:|$)" a --- | Convert an account name to a regular expression matching it and its subaccounts.+-- | Convert an account name to a regular expression matching it but not its subaccounts. accountNameToAccountOnlyRegex :: String -> String accountNameToAccountOnlyRegex "" = "" accountNameToAccountOnlyRegex a = printf "^%s$" a

@@ -44,6 +44,7 @@ module Hledger.Data.Amount (   -- * Amount   nullamt,+  missingamt,   amountWithCommodity,   canonicaliseAmountCommodity,   setAmountPrecision,@@ -58,7 +59,7 @@   maxprecisionwithpoint,   -- * MixedAmount   nullmixedamt,-  missingamt,+  missingmixedamt,   amounts,   normaliseMixedAmountPreservingFirstPrice,   canonicaliseMixedAmountCommodity,@@ -96,7 +97,7 @@ ------------------------------------------------------------------------------- -- Amount -instance Show Amount where show = showAmount+instance Show Amount where show = showAmountDebug  instance Num Amount where     abs (Amount c q p) = Amount c (abs q) p@@ -147,12 +148,14 @@  -- | Does this amount appear to be zero when displayed with its given precision ? isZeroAmount :: Amount -> Bool-isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPriceOrCommodity+isZeroAmount a --  a==missingamt = False+               | otherwise     = (null . filter (`elem` "123456789") . showAmountWithoutPriceOrCommodity) a  -- | Is this amount "really" zero, regardless of the display precision ? -- Since we are using floating point, for now just test to some high precision. isReallyZeroAmount :: Amount -> Bool-isReallyZeroAmount = null . filter (`elem` "123456789") . printf ("%."++show zeroprecision++"f") . quantity+isReallyZeroAmount a --  a==missingamt = False+                     | otherwise     = (null . filter (`elem` "123456789") . printf ("%."++show zeroprecision++"f") . quantity) a     where zeroprecision = 8  -- | Get the string representation of an amount, based on its commodity's@@ -166,8 +169,9 @@  -- | Get the unambiguous string representation of an amount, for debugging. showAmountDebug :: Amount -> String+showAmountDebug (Amount (Commodity {symbol="AUTO"}) _ _) = "(missing)" showAmountDebug (Amount c q pri) = printf "Amount {commodity = %s, quantity = %s, price = %s}"-                                   (show c) (show q) (maybe "" showPriceDebug pri)+                                   (show c) (show q) (maybe "Nothing" showPriceDebug pri)  -- | Get the string representation of an amount, without any \@ price. showAmountWithoutPrice :: Amount -> String@@ -189,7 +193,7 @@ -- display settings. String representations equivalent to zero are -- converted to just \"0\". showAmount :: Amount -> String-showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = "" -- can appear in an error message+showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = "" showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) _ pri) =     case side of       L -> printf "%s%s%s%s" sym' space quantity' price@@ -257,7 +261,7 @@ ------------------------------------------------------------------------------- -- MixedAmount -instance Show MixedAmount where show = showMixedAmount+instance Show MixedAmount where show = showMixedAmountDebug  instance Num MixedAmount where     fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing]@@ -272,22 +276,31 @@ nullmixedamt = Mixed []  -- | A temporary value for parsed transactions which had no amount specified.-missingamt :: MixedAmount-missingamt = Mixed [Amount unknown{symbol="AUTO"} 0 Nothing]+missingamt :: Amount+missingamt = Amount unknown{symbol="AUTO"} 0 Nothing --- | Simplify a mixed amount's component amounts: combine amounts with--- the same commodity and price. Also remove any zero amounts and+missingmixedamt :: MixedAmount+missingmixedamt = Mixed [missingamt]++-- | Simplify a mixed amount's component amounts: combine amounts with the+-- same commodity and 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 (\a -> isReallyZeroAmount a && Mixed [a] /= missingamt) as'+      (_,nonzeros) = partition isReallyZeroAmount $ filter (/= missingamt) as'       as' = map sumAmountsUsingFirstPrice $ group $ sort as       sort = sortBy (\a1 a2 -> compare (sym a1,price a1) (sym a2,price a2))       group = groupBy (\a1 a2 -> sym a1 == sym a2 && price a1 == price a2)       sym = symbol . commodity +tests_normaliseMixedAmountPreservingPrices = [+  "normaliseMixedAmountPreservingPrices" ~: do+   -- assertEqual "" (Mixed [dollars 2]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, dollars 2])+   assertEqual "" (Mixed [nullamt]) (normaliseMixedAmountPreservingPrices $ Mixed [dollars 0, missingamt])+ ]+ -- | 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@@ -297,7 +310,7 @@ normaliseMixedAmountPreservingFirstPrice (Mixed as) = Mixed as''     where        as'' = if null nonzeros then [nullamt] else nonzeros-      (_,nonzeros) = partition (\a -> isReallyZeroAmount a && Mixed [a] /= missingamt) as'+      (_,nonzeros) = partition (\a -> isReallyZeroAmount a && a /= missingamt) as'       as' = map sumAmountsUsingFirstPrice $ group $ sort as       sort = sortBy (\a1 a2 -> compare (sym a1) (sym a2))       group = groupBy (\a1 a2 -> sym a1 == sym a2)@@ -362,7 +375,7 @@ -- its component amounts. NB a mixed amount can have an empty amounts -- list in which case it shows as \"\". showMixedAmount :: MixedAmount -> String-showMixedAmount m = vConcatRightAligned $ map show $ amounts $ normaliseMixedAmountPreservingFirstPrice m+showMixedAmount m = vConcatRightAligned $ map showAmount $ amounts $ normaliseMixedAmountPreservingFirstPrice m  -- | Set the display precision in the amount's commodities. setMixedAmountPrecision :: Int -> MixedAmount -> MixedAmount@@ -377,8 +390,9 @@  -- | Get an unambiguous string representation of a mixed amount for debugging. showMixedAmountDebug :: MixedAmount -> String-showMixedAmountDebug m = printf "Mixed [%s]" as-    where as = intercalate "\n       " $ map showAmountDebug $ amounts $ normaliseMixedAmountPreservingFirstPrice m+showMixedAmountDebug m | m == missingmixedamt = "(missing)"+                       | otherwise       = printf "Mixed [%s]" as+    where as = intercalate "\n       " $ map showAmountDebug $ amounts m -- normaliseMixedAmountPreservingFirstPrice m  -- | Get the string representation of a mixed amount, but without -- any \@ prices.@@ -387,7 +401,7 @@     where       (Mixed as) = normaliseMixedAmountPreservingFirstPrice $ stripPrices m       stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{price=Nothing}-      width = maximum $ map (length . show) as+      width = maximum $ map (length . showAmount) as       showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice  -- | Replace a mixed amount's commodity with the canonicalised version from@@ -398,7 +412,9 @@ ------------------------------------------------------------------------------- -- misc -tests_Hledger_Data_Amount = TestList [+tests_Hledger_Data_Amount = TestList $+     tests_normaliseMixedAmountPreservingPrices+  ++ [    -- Amount @@ -461,7 +477,7 @@     showMixedAmount (Mixed [(dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}]) `is` "$1.00 @ €2.00"     showMixedAmount (Mixed [dollars 0]) `is` "0"     showMixedAmount (Mixed []) `is` "0"-    showMixedAmount missingamt `is` ""+    showMixedAmount missingmixedamt `is` ""    ,"showMixedAmountWithoutPrice" ~: do     let a = (dollars 1){price=Just $ UnitPrice $ Mixed [euros 2]}

@@ -20,7 +20,38 @@  -- XXX fromGregorian silently clips bad dates, use fromGregorianValid instead ? -module Hledger.Data.Dates+module Hledger.Data.Dates (+  -- * Misc date handling utilities+  getCurrentDay,+  getCurrentMonth,+  getCurrentYear,+  nulldate,+  spanContainsDate,+  parsedate,+  showDate,+  elapsedSeconds,+  prevday,+  parsePeriodExpr,+  nulldatespan,+  tests_Hledger_Data_Dates,+  failIfInvalidYear,+  datesepchar,+  datesepchars,+  spanIntersect,+  spansIntersect,+  spanUnion,+  spansUnion,+  orDatesFrom,+  smartdate,+  splitSpan,+  fixSmartDate,+  fixSmartDateStr,+  fixSmartDateStrEither,+  fixSmartDateStrEither',+  daysInSpan,+  maybePeriod,+  mkdatespan,+) where  import Control.Monad@@ -116,12 +147,28 @@     where a = if isJust a1 then a1 else a2           b = if isJust b1 then b1 else b2 +-- | Calculate the intersection of a number of datespans.+spansIntersect [] = nulldatespan+spansIntersect [d] = d+spansIntersect (d:ds) = d `spanIntersect` (spansIntersect ds)+ -- | Calculate the intersection of two datespans. spanIntersect (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan b e     where       b = latest b1 b2       e = earliest e1 e2 +-- | Calculate the union of a number of datespans.+spansUnion [] = nulldatespan+spansUnion [d] = d+spansUnion (d:ds) = d `spanUnion` (spansUnion ds)++-- | Calculate the union of two datespans.+spanUnion (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan b e+    where+      b = earliest b1 b2+      e = latest e1 e2+ latest d Nothing = d latest Nothing d = d latest (Just d1) (Just d2) = Just $ max d1 d2@@ -139,18 +186,18 @@ maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate  -- | Show a DateSpan as a human-readable pseudo-period-expression string.-dateSpanAsText :: DateSpan -> String-dateSpanAsText (DateSpan Nothing Nothing)   = "all"-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)+-- dateSpanAsText :: DateSpan -> String+-- dateSpanAsText (DateSpan Nothing Nothing)   = "all"+-- 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-spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate-    where-      sdate = fromparse $ parsewith smartdateonly s+-- spanFromSmartDateString :: Day -> String -> DateSpan+-- spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate+--     where+--       sdate = fromparse $ parsewith smartdateonly s  spanFromSmartDate :: Day -> SmartDate -> DateSpan spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)@@ -183,8 +230,8 @@       span (y,m,"")              = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1       span (y,m,d)               = (day, nextday day) where day = fromGregorian (read y) (read m) (read d) -showDay :: Day -> String-showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day+-- showDay :: Day -> String+-- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day  -- | Convert a smart date string to an explicit yyyy\/mm\/dd string using -- the provided reference date, or raise an error.@@ -280,16 +327,12 @@ ---------------------------------------------------------------------- -- parsing -firstJust ms = case dropWhile (==Nothing) ms of-    [] -> Nothing-    (md:_) -> md---- | Parse a couple of date-time string formats to a time type.-parsedatetimeM :: String -> Maybe LocalTime-parsedatetimeM s = firstJust [-    parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s,-    parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s-    ]+-- -- | Parse a couple of date-time string formats to a time type.+-- parsedatetimeM :: String -> Maybe LocalTime+-- parsedatetimeM s = firstJust [+--     parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s,+--     parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s+--     ]  -- | Parse a couple of date string formats to a time type. parsedateM :: String -> Maybe Day@@ -298,10 +341,10 @@      parseTime defaultTimeLocale "%Y-%m-%d" s       ] --- | Parse a date-time string to a time type, or raise an error.-parsedatetime :: String -> LocalTime-parsedatetime s = fromMaybe (error' $ "could not parse timestamp \"" ++ s ++ "\"")-                            (parsedatetimeM s)+-- -- | Parse a date-time string to a time type, or raise an error.+-- parsedatetime :: String -> LocalTime+-- parsedatetime s = fromMaybe (error' $ "could not parse timestamp \"" ++ s ++ "\"")+--                             (parsedatetimeM s)  -- | Parse a date string to a time type, or raise an error. parsedate :: String -> Day@@ -410,8 +453,8 @@ months         = ["january","february","march","april","may","june",                   "july","august","september","october","november","december"] monthabbrevs   = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"]-weekdays       = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"]-weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"]+-- weekdays       = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"]+-- weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"]  monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months monIndex s   = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs

@@ -0,0 +1,118 @@+module Hledger.Data.FormatStrings (+          parseFormatString+        , formatStrings+        , formatValue+        , FormatString(..)+        , HledgerFormatField(..)+        , tests+        ) where++import Numeric+import Data.Char (isPrint)+import Data.Maybe+import Test.HUnit+import Text.ParserCombinators.Parsec+import Text.Printf++import Hledger.Data.Types+++formatValue :: Bool -> Maybe Int -> Maybe Int -> String -> String+formatValue leftJustified min max value = printf formatS value+    where+      l = if leftJustified then "-" else ""+      min' = maybe "" show min+      max' = maybe "" (\i -> "." ++ (show i)) max+      formatS = "%" ++ l ++ min' ++ max' ++ "s"++parseFormatString :: String -> Either String [FormatString]+parseFormatString input = case (runParser formatStrings () "(unknown)") input of+    Left y -> Left $ show y+    Right x -> Right x++{-+Parsers+-}++field :: GenParser Char st HledgerFormatField+field = do+        try (string "account" >> return AccountField)+    <|> try (string "depth_spacer" >> return DepthSpacerField)+    <|> try (string "date" >> return DescriptionField)+    <|> try (string "description" >> return DescriptionField)+    <|> try (string "total" >> return TotalField)+    <|> try (many1 digit >>= (\s -> return $ FieldNo $ read s))++formatField :: GenParser Char st FormatString+formatField = do+    char '%'+    leftJustified <- optionMaybe (char '-')+    minWidth <- optionMaybe (many1 $ digit)+    maxWidth <- optionMaybe (do char '.'; many1 $ digit) -- TODO: Can this be (char '1') *> (many1 digit)+    char '('+    f <- field+    char ')'+    return $ FormatField (isJust leftJustified) (parseDec minWidth) (parseDec maxWidth) f+    where+      parseDec s = case s of+        Just text -> Just m where ((m,_):_) = readDec text+        _ -> Nothing++formatLiteral :: GenParser Char st FormatString+formatLiteral = do+    s <- many1 c+    return $ FormatLiteral s+    where+      isPrintableButNotPercentage x = isPrint x && (not $ x == '%')+      c =     (satisfy isPrintableButNotPercentage <?> "printable character")+          <|> try (string "%%" >> return '%')++formatString :: GenParser Char st FormatString+formatString =+        formatField+    <|> formatLiteral++formatStrings :: GenParser Char st [FormatString]+formatStrings = many formatString++testFormat :: FormatString -> String -> String -> Assertion+testFormat fs value expected = assertEqual name expected actual+    where+        (name, actual) = case fs of+            FormatLiteral l -> ("literal", formatValue False Nothing Nothing l)+            FormatField leftJustify min max _ -> ("field", formatValue leftJustify min max value)++testParser :: String -> [FormatString] -> Assertion+testParser s expected = case (parseFormatString s) of+    Left  error -> assertFailure $ show error+    Right actual -> assertEqual ("Input: " ++ s) expected actual++tests = test [ formattingTests ++ parserTests ]++formattingTests = [+      testFormat (FormatLiteral " ")                                ""            " "+    , testFormat (FormatField False Nothing Nothing DescriptionField)    "description" "description"+    , testFormat (FormatField False (Just 20) Nothing DescriptionField)  "description" "         description"+    , testFormat (FormatField False Nothing (Just 20) DescriptionField)  "description" "description"+    , testFormat (FormatField True Nothing (Just 20) DescriptionField)   "description" "description"+    , testFormat (FormatField True (Just 20) Nothing DescriptionField)   "description" "description         "+    , testFormat (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description         "+    , testFormat (FormatField True Nothing (Just 3) DescriptionField)    "description" "des"+    ]++parserTests = [+      testParser ""                             []+    , testParser "D"                            [FormatLiteral "D"]+    , testParser "%(date)"                      [FormatField False Nothing Nothing DescriptionField]+    , testParser "%(total)"                     [FormatField False Nothing Nothing TotalField]+    , testParser "Hello %(date)!"               [FormatLiteral "Hello ", FormatField False Nothing Nothing DescriptionField, FormatLiteral "!"]+    , testParser "%-(date)"                     [FormatField True Nothing Nothing DescriptionField]+    , testParser "%20(date)"                    [FormatField False (Just 20) Nothing DescriptionField]+    , testParser "%.10(date)"                   [FormatField False Nothing (Just 10) DescriptionField]+    , testParser "%20.10(date)"                 [FormatField False (Just 20) (Just 10) DescriptionField]+    , testParser "%20(account) %.10(total)\n"   [ FormatField False (Just 20) Nothing AccountField+                                                , FormatLiteral " "+                                                , FormatField False Nothing (Just 10) TotalField+                                                , FormatLiteral "\n"+                                                ]+  ]

@@ -1,15 +1,59 @@ {-| -A 'Journal' is a set of 'Transaction's and related data, usually parsed-from a hledger/ledger journal file or timelog. This is the primary hledger-data object.+A 'Journal' is a set of transactions, plus optional related data.  This is+hledger's primary data object. It is usually parsed from a journal file or+other data format (see "Hledger.Read").  -} -module Hledger.Data.Journal+module Hledger.Data.Journal (+  -- * Parsing helpers+  addHistoricalPrice,+  addModifierTransaction,+  addPeriodicTransaction,+  addTimeLogEntry,+  addTransaction,+  journalApplyAliases,+  journalBalanceTransactions,+  journalCanonicaliseAmounts,+  journalConvertAmountsToCost,+  journalFinalise,+  journalSelectingDate,+  -- * Filtering+  filterJournalPostings,+  filterJournalTransactions,+  -- * Querying+  journalAccountInfo,+  journalAccountNames,+  journalAccountNamesUsed,+  journalAmountAndPriceCommodities,+  journalAmounts,+  journalCanonicalCommodities,+  journalDateSpan,+  journalFilePath,+  journalFilePaths,+  journalPostings,+  -- * Standard account types+  journalBalanceSheetAccountQuery,+  journalProfitAndLossAccountQuery,+  journalIncomeAccountQuery,+  journalExpenseAccountQuery,+  journalAssetAccountQuery,+  journalLiabilityAccountQuery,+  journalEquityAccountQuery,+  journalCashAccountQuery,+  -- * Misc+  groupPostings,+  matchpats,+  nullctx,+  nulljournal,+  -- * Tests+  samplejournal,+  tests_Hledger_Data_Journal,+) where import Data.List-import Data.Map (findWithDefault, (!))+import Data.Map (findWithDefault, (!), toAscList) import Data.Ord import Data.Time.Calendar import Data.Time.LocalTime@@ -23,13 +67,14 @@ import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName+import Hledger.Data.Account() import Hledger.Data.Amount-import Hledger.Data.Commodity (canonicaliseCommodities)-import Hledger.Data.Dates (nulldatespan)-import Hledger.Data.Transaction (journalTransactionWithDate,balanceTransaction)+import Hledger.Data.Commodity+import Hledger.Data.Dates+import Hledger.Data.Transaction import Hledger.Data.Posting import Hledger.Data.TimeLog-import Hledger.Data.Matching+import Hledger.Query   instance Show Journal where@@ -43,17 +88,17 @@              -- ++ (show $ journalTransactions l)              where accounts = flatten $ journalAccountNameTree j -showJournalDebug j = unlines [-                      show j-                     ,show (jtxns j)-                     ,show (jmodifiertxns j)-                     ,show (jperiodictxns j)-                     ,show $ open_timelog_entries j-                     ,show $ historical_prices j-                     ,show $ final_comment_lines j-                     ,show $ jContext j-                     ,show $ map fst $ files j-                     ]+-- showJournalDebug j = unlines [+--                       show j+--                      ,show (jtxns j)+--                      ,show (jmodifiertxns j)+--                      ,show (jperiodictxns j)+--                      ,show $ open_timelog_entries j+--                      ,show $ historical_prices j+--                      ,show $ final_comment_lines j+--                      ,show $ jContext j+--                      ,show $ map fst $ files j+--                      ]  nulljournal :: Journal nulljournal = Journal { jmodifiertxns = []@@ -70,17 +115,6 @@ nullctx :: JournalContext nullctx = Ctx { ctxYear = Nothing, ctxCommodity = Nothing, ctxAccount = [], ctxAliases = [] } -nullfilterspec :: FilterSpec-nullfilterspec = FilterSpec {-     datespan=nulldatespan-    ,cleared=Nothing-    ,real=False-    ,empty=False-    ,acctpats=[]-    ,descpats=[]-    ,depth=Nothing-    }- journalFilePath :: Journal -> FilePath journalFilePath = fst . mainfile @@ -108,6 +142,7 @@ journalPostings :: Journal -> [Posting] journalPostings = concatMap tpostings . jtxns +-- | All account names used in this journal. journalAccountNamesUsed :: Journal -> [AccountName] journalAccountNamesUsed = sort . accountNamesFromPostings . journalPostings @@ -117,6 +152,55 @@ journalAccountNameTree :: Journal -> Tree AccountName journalAccountNameTree = accountNameTreeFrom . journalAccountNames +-- standard account types++-- | A query for Profit & Loss accounts in this journal.+-- Cf <http://en.wikipedia.org/wiki/Chart_of_accounts#Profit_.26_Loss_accounts>.+journalProfitAndLossAccountQuery  :: Journal -> Query+journalProfitAndLossAccountQuery j = Or [journalIncomeAccountQuery j+                                               ,journalExpenseAccountQuery j+                                               ]++-- | A query for Income (Revenue) accounts in this journal.+-- This is currently hard-coded to the case-insensitive regex @^(income|revenue)s?(:|$)@.+journalIncomeAccountQuery  :: Journal -> Query+journalIncomeAccountQuery _ = Acct "^(income|revenue)s?(:|$)"++-- | A query for Expense accounts in this journal.+-- This is currently hard-coded to the case-insensitive regex @^expenses?(:|$)@.+journalExpenseAccountQuery  :: Journal -> Query+journalExpenseAccountQuery _ = Acct "^expenses?(:|$)"++-- | A query for Asset, Liability & Equity accounts in this journal.+-- Cf <http://en.wikipedia.org/wiki/Chart_of_accounts#Balance_Sheet_Accounts>.+journalBalanceSheetAccountQuery  :: Journal -> Query+journalBalanceSheetAccountQuery j = Or [journalAssetAccountQuery j+                                              ,journalLiabilityAccountQuery j+                                              ,journalEquityAccountQuery j+                                              ]++-- | A query for Asset accounts in this journal.+-- This is currently hard-coded to the case-insensitive regex @^assets?(:|$)@.+journalAssetAccountQuery  :: Journal -> Query+journalAssetAccountQuery _ = Acct "^assets?(:|$)"++-- | A query for Liability accounts in this journal.+-- This is currently hard-coded to the case-insensitive regex @^liabilit(y|ies)(:|$)@.+journalLiabilityAccountQuery  :: Journal -> Query+journalLiabilityAccountQuery _ = Acct "^liabilit(y|ies)(:|$)"++-- | A query for Equity accounts in this journal.+-- This is currently hard-coded to the case-insensitive regex @^equity(:|$)@.+journalEquityAccountQuery  :: Journal -> Query+journalEquityAccountQuery _ = Acct "^equity(:|$)"++-- | A query for Cash (-equivalent) accounts in this journal (ie,+-- accounts which appear on the cashflow statement.)  This is currently+-- hard-coded to be all the Asset accounts except for those containing the+-- case-insensitive regex @(receivable|A/R)@.+journalCashAccountQuery  :: Journal -> Query+journalCashAccountQuery j = And [journalAssetAccountQuery j, Not $ Acct "(receivable|A/R)"]+ -- Various kinds of filtering on journals. We do it differently depending -- on the command. @@ -125,15 +209,16 @@  -- | Keep only postings matching the query expression. -- This can leave unbalanced transactions.-filterJournalPostings2 :: Matcher -> Journal -> Journal-filterJournalPostings2 m j@Journal{jtxns=ts} = j{jtxns=map filtertransactionpostings ts}+filterJournalPostings :: Query -> Journal -> Journal+filterJournalPostings q j@Journal{jtxns=ts} = j{jtxns=map filtertransactionpostings ts}     where-      filtertransactionpostings t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps}+      filtertransactionpostings t@Transaction{tpostings=ps} = t{tpostings=filter (q `matchesPosting`) ps}  -- | Keep only transactions matching the query expression.-filterJournalTransactions2 :: Matcher -> Journal -> Journal-filterJournalTransactions2 m j@Journal{jtxns=ts} = j{jtxns=filter (m `matchesTransaction`) ts}+filterJournalTransactions :: Query -> Journal -> Journal+filterJournalTransactions q j@Journal{jtxns=ts} = j{jtxns=filter (q `matchesTransaction`) ts} +{- ------------------------------------------------------------------------------- -- filtering V1 @@ -147,10 +232,12 @@                                     ,acctpats=apats                                     ,descpats=dpats                                     ,depth=depth+                                    ,fMetadata=md                                     } =     filterJournalTransactionsByClearedStatus cleared .     filterJournalPostingsByDepth depth .     filterJournalTransactionsByAccount apats .+    filterJournalTransactionsByMetadata md .     filterJournalTransactionsByDescription dpats .     filterJournalTransactionsByDate datespan @@ -164,15 +251,22 @@                                 ,acctpats=apats                                 ,descpats=dpats                                 ,depth=depth+                                ,fMetadata=md                                 } =     filterJournalPostingsByRealness real .     filterJournalPostingsByClearedStatus cleared .     filterJournalPostingsByEmpty empty .     filterJournalPostingsByDepth depth .     filterJournalPostingsByAccount apats .+    filterJournalTransactionsByMetadata md .     filterJournalTransactionsByDescription dpats .     filterJournalTransactionsByDate datespan +-- | Keep only transactions whose metadata matches all metadata specifications.+filterJournalTransactionsByMetadata :: [(String,String)] -> Journal -> Journal+filterJournalTransactionsByMetadata pats j@Journal{jtxns=ts} = j{jtxns=filter matchmd ts}+    where matchmd t = all (`elem` tmetadata t) pats+ -- | Keep only transactions whose description matches the description patterns. filterJournalTransactionsByDescription :: [String] -> Journal -> Journal filterJournalTransactionsByDescription pats j@Journal{jtxns=ts} = j{jtxns=filter matchdesc ts}@@ -202,21 +296,21 @@ -- | Strip out any virtual postings, if the flag is true, otherwise do -- no filtering. filterJournalPostingsByRealness :: Bool -> Journal -> Journal-filterJournalPostingsByRealness False l = l+filterJournalPostingsByRealness False j = j filterJournalPostingsByRealness True j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}     where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter isReal ps}  -- | Strip out any postings with zero amount, unless the flag is true. filterJournalPostingsByEmpty :: Bool -> Journal -> Journal-filterJournalPostingsByEmpty True l = l+filterJournalPostingsByEmpty True j = j filterJournalPostingsByEmpty False j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}     where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (not . isEmptyPosting) ps} --- | Keep only transactions which affect accounts deeper than the specified depth.-filterJournalTransactionsByDepth :: Maybe Int -> Journal -> Journal-filterJournalTransactionsByDepth Nothing j = j-filterJournalTransactionsByDepth (Just d) j@Journal{jtxns=ts} =-    j{jtxns=(filter (any ((<= d+1) . accountNameLevel . paccount) . tpostings) ts)}+-- -- | Keep only transactions which affect accounts deeper than the specified depth.+-- filterJournalTransactionsByDepth :: Maybe Int -> Journal -> Journal+-- filterJournalTransactionsByDepth Nothing j = j+-- filterJournalTransactionsByDepth (Just d) j@Journal{jtxns=ts} =+--     j{jtxns=(filter (any ((<= d+1) . accountNameLevel . paccount) . tpostings) ts)}  -- | Strip out any postings to accounts deeper than the specified depth -- (and any transactions which have no postings as a result).@@ -227,6 +321,12 @@     where filtertxns t@Transaction{tpostings=ps} =               t{tpostings=filter ((<= d) . accountNameLevel . paccount) ps} +-- | Keep only postings which affect accounts matched by the account patterns.+-- This can leave transactions unbalanced.+filterJournalPostingsByAccount :: [String] -> Journal -> Journal+filterJournalPostingsByAccount apats j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}+    where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (matchpats apats . paccount) ps}+ -- | Keep only transactions which affect accounts matched by the account patterns. -- More precisely: each positive account pattern excludes transactions -- which do not contain a posting to a matched account, and each negative@@ -241,11 +341,7 @@       amatch pat a = regexMatchesCI (abspat pat) a       (negatives,positives) = partition isnegativepat apats --- | Keep only postings which affect accounts matched by the account patterns.--- This can leave transactions unbalanced.-filterJournalPostingsByAccount :: [String] -> Journal -> Journal-filterJournalPostingsByAccount apats j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}-    where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (matchpats apats . paccount) ps}+-}  -- | Convert this journal's transactions' primary date to either the -- actual or effective date.@@ -261,7 +357,9 @@       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.+-- | 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} =     journalBalanceTransactions $@@ -293,25 +391,25 @@       fixcommodity c@Commodity{symbol=s} = findWithDefault c s canonicalcommoditymap       canonicalcommoditymap = journalCanonicalCommodities j --- | Apply this journal's historical price records to unpriced amounts where possible.-journalApplyHistoricalPrices :: Journal -> Journal-journalApplyHistoricalPrices j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts}-    where-      fixtransaction t@Transaction{tdate=d, tpostings=ps} = t{tpostings=map fixposting ps}-       where-        fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}-        fixmixedamount (Mixed as) = Mixed $ map fixamount as-        fixamount = fixprice-        fixprice a@Amount{price=Just _} = a-        fixprice a@Amount{commodity=c} = a{price=maybe Nothing (Just . UnitPrice) $ journalHistoricalPriceFor j d c}+-- -- | Apply this journal's historical price records to unpriced amounts where possible.+-- journalApplyHistoricalPrices :: Journal -> Journal+-- journalApplyHistoricalPrices j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts}+--     where+--       fixtransaction t@Transaction{tdate=d, tpostings=ps} = t{tpostings=map fixposting ps}+--        where+--         fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}+--         fixmixedamount (Mixed as) = Mixed $ map fixamount as+--         fixamount = fixprice+--         fixprice a@Amount{price=Just _} = a+--         fixprice a@Amount{commodity=c} = a{price=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.-journalHistoricalPriceFor :: Journal -> Day -> Commodity -> Maybe MixedAmount-journalHistoricalPriceFor j d Commodity{symbol=s} = do-  let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices j-  case ps of (HistoricalPrice{hamount=a}:_) -> Just a-             _ -> Nothing+-- -- | Get the price for a commodity on the specified day from the price database, if known.+-- -- Does only one lookup step, ie will not look up the price of a price.+-- journalHistoricalPriceFor :: Journal -> Day -> Commodity -> Maybe MixedAmount+-- journalHistoricalPriceFor j d Commodity{symbol=s} = do+--   let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices j+--   case ps of (HistoricalPrice{hamount=a}:_) -> Just a+--              _ -> Nothing  -- | Close any open timelog sessions in this journal using the provided current time. journalCloseTimeLogEntries :: LocalTime -> Journal -> Journal@@ -360,6 +458,8 @@     where       ts = sortBy (comparing tdate) $ jtxns j +-- Misc helpers+ -- | Check if a set of hledger account/description filter patterns matches the -- given account name or entry description.  Patterns are case-insensitive -- regular expressions. Prefixed with not:, they become anti-patterns.@@ -386,13 +486,168 @@       amap = Map.fromList [(a, acctinfo a) | a <- flatten ant]       acctinfo a = Account a (psof a) (inclbalof a) +tests_journalAccountInfo = [+ "journalAccountInfo" ~: do+   let (t,m) = journalAccountInfo samplejournal+   assertEqual "account tree"+    (Node "top" [+      Node "assets" [+       Node "assets:bank" [+        Node "assets:bank:checking" [],+        Node "assets:bank:saving" []+        ],+       Node "assets:cash" []+       ],+      Node "expenses" [+       Node "expenses:food" [],+       Node "expenses:supplies" []+       ],+      Node "income" [+       Node "income:gifts" [],+       Node "income:salary" []+       ],+      Node "liabilities" [+       Node "liabilities:debts" []+       ]+      ]+     )+    t+   mapM_ +         (\(e,a) -> assertEqual "" e a)+         (zip [+               ("assets",Account "assets" [] (Mixed [dollars (-1)]))+              ,("assets:bank",Account "assets:bank" [] (Mixed [dollars 1]))+              ,("assets:bank:checking",Account "assets:bank:checking" [+                  Posting {+                    pstatus=False,+                    paccount="assets:bank:checking",+                    pamount=(Mixed [dollars 1]),+                    pcomment="",+                    ptype=RegularPosting,+                    ptags=[],+                    ptransaction=Nothing+                  },+                  Posting {+                    pstatus=False,+                    paccount="assets:bank:checking",+                    pamount=(Mixed [dollars 1]),+                    pcomment="",+                    ptype=RegularPosting,+                    ptags=[],+                    ptransaction=Nothing+                  },+                  Posting {+                    pstatus=False,+                    paccount="assets:bank:checking",+                    pamount=(Mixed [dollars (-1)]),+                    pcomment="",+                    ptype=RegularPosting,+                    ptags=[],+                    ptransaction=Nothing+                  },+                  Posting {+                    pstatus=False,+                    paccount="assets:bank:checking",+                    pamount=(Mixed [dollars (-1)]),+                    pcomment="",+                    ptype=RegularPosting,+                    ptags=[],+                    ptransaction=Nothing+                  }+                  ] (Mixed [nullamt]))+              ,("assets:bank:saving",Account "assets:bank:saving" [+                  Posting {+                    pstatus=False,+                    paccount="assets:bank:saving",+                    pamount=(Mixed [dollars 1]),+                    pcomment="",+                    ptype=RegularPosting,+                    ptags=[],+                    ptransaction=Nothing+                  }+                  ] (Mixed [dollars 1]))+              ,("assets:cash",Account "assets:cash" [+                  Posting {+                    pstatus=False,+                    paccount="assets:cash",+                    pamount=(Mixed [dollars (-2)]),+                    pcomment="",+                    ptype=RegularPosting,+                    ptags=[],+                    ptransaction=Nothing+                  }+                ] (Mixed [dollars (-2)]))+              ,("expenses",Account "expenses" [] (Mixed [dollars 2]))+              ,("expenses:food",Account "expenses:food" [+                  Posting {+                    pstatus=False,+                    paccount="expenses:food",+                    pamount=(Mixed [dollars 1]),+                    pcomment="",+                    ptype=RegularPosting,+                    ptags=[],+                    ptransaction=Nothing+                  }+                ] (Mixed [dollars 1]))+              ,("expenses:supplies",Account "expenses:supplies" [+                  Posting {+                    pstatus=False,+                    paccount="expenses:supplies",+                    pamount=(Mixed [dollars 1]),+                    pcomment="",+                    ptype=RegularPosting,+                    ptags=[],+                    ptransaction=Nothing+                  }+                ] (Mixed [dollars 1]))+              ,("income",Account "income" [] (Mixed [dollars (-2)]))+              ,("income:gifts",Account "income:gifts" [+                  Posting {+                    pstatus=False,+                    paccount="income:gifts",+                    pamount=(Mixed [dollars (-1)]),+                    pcomment="",+                    ptype=RegularPosting,+                    ptags=[],+                    ptransaction=Nothing+                  }+                ] (Mixed [dollars (-1)]))+              ,("income:salary",Account "income:salary" [+                  Posting {+                    pstatus=False,+                    paccount="income:salary",+                    pamount=(Mixed [dollars (-1)]),+                    pcomment="",+                    ptype=RegularPosting,+                    ptags=[],+                    ptransaction=Nothing+                  }+                  ] (Mixed [dollars (-1)]))+              ,("liabilities",Account "liabilities" [] (Mixed [dollars 1]))+              ,("liabilities:debts",Account "liabilities:debts" [+                  Posting {+                    pstatus=False,+                    paccount="liabilities:debts",+                    pamount=(Mixed [dollars 1]),+                    pcomment="",+                    ptype=RegularPosting,+                    ptags=[],+                    ptransaction=Nothing+                  }+                ] (Mixed [dollars 1]))+              ,("top",Account "top" [] (Mixed [nullamt]))+             ]+             (toAscList m)+         )+ ]+ -- | Given a list of postings, return an account name tree and three query -- functions that fetch postings, subaccount-excluding-balance and -- subaccount-including-balance by account name. groupPostings :: [Posting] -> (Tree AccountName,-                             (AccountName -> [Posting]),-                             (AccountName -> MixedAmount),-                             (AccountName -> MixedAmount))+                               (AccountName -> [Posting]),+                               (AccountName -> MixedAmount),+                               (AccountName -> MixedAmount)) groupPostings ps = (ant, psof, exclbalof, inclbalof)     where       anames = sort $ nub $ map paccount ps@@ -426,9 +681,215 @@       m' = Map.fromList [(paccount $ head g, g) | g <- groupedps]  -- debug helpers-traceAmountPrecision a = trace (show $ map (precision . commodity) $ amounts a) a-tracePostingsCommodities ps = trace (show $ map ((map (precision . commodity) . amounts) . pamount) ps) ps+-- traceAmountPrecision a = trace (show $ map (precision . commodity) $ amounts a) a+-- tracePostingsCommodities ps = trace (show $ map ((map (precision . commodity) . amounts) . pamount) ps) ps -tests_Hledger_Data_Journal = TestList [- ]+-- tests +-- A sample journal for testing, similar to data/sample.journal:+--+-- 2008/01/01 income+--     assets:bank:checking  $1+--     income:salary+--+-- 2008/06/01 gift+--     assets:bank:checking  $1+--     income:gifts+--+-- 2008/06/02 save+--     assets:bank:saving  $1+--     assets:bank:checking+--+-- 2008/06/03 * eat & shop+--     expenses:food      $1+--     expenses:supplies  $1+--     assets:cash+--+-- 2008/12/31 * pay off+--     liabilities:debts  $1+--     assets:bank:checking+--+Right samplejournal = journalBalanceTransactions $ Journal+          [] +          [] +          [+           txnTieKnot $ Transaction {+             tdate=parsedate "2008/01/01",+             teffectivedate=Nothing,+             tstatus=False,+             tcode="",+             tdescription="income",+             tcomment="",+             ttags=[],+             tpostings=[+              Posting {+                pstatus=False,+                paccount="assets:bank:checking",+                pamount=(Mixed [dollars 1]),+                pcomment="",+                ptype=RegularPosting,+                ptags=[],+                ptransaction=Nothing+              },+              Posting {+                pstatus=False,+                paccount="income:salary",+                pamount=(missingmixedamt),+                pcomment="",+                ptype=RegularPosting,+                ptags=[],+                ptransaction=Nothing+              }+             ],+             tpreceding_comment_lines=""+           }+          ,+           txnTieKnot $ Transaction {+             tdate=parsedate "2008/06/01",+             teffectivedate=Nothing,+             tstatus=False,+             tcode="",+             tdescription="gift",+             tcomment="",+             ttags=[],+             tpostings=[+              Posting {+                pstatus=False,+                paccount="assets:bank:checking",+                pamount=(Mixed [dollars 1]),+                pcomment="",+                ptype=RegularPosting,+                ptags=[],+                ptransaction=Nothing+              },+              Posting {+                pstatus=False,+                paccount="income:gifts",+                pamount=(missingmixedamt),+                pcomment="",+                ptype=RegularPosting,+                ptags=[],+                ptransaction=Nothing+              }+             ],+             tpreceding_comment_lines=""+           }+          ,+           txnTieKnot $ Transaction {+             tdate=parsedate "2008/06/02",+             teffectivedate=Nothing,+             tstatus=False,+             tcode="",+             tdescription="save",+             tcomment="",+             ttags=[],+             tpostings=[+              Posting {+                pstatus=False,+                paccount="assets:bank:saving",+                pamount=(Mixed [dollars 1]),+                pcomment="",+                ptype=RegularPosting,+                ptags=[],+                ptransaction=Nothing+              },+              Posting {+                pstatus=False,+                paccount="assets:bank:checking",+                pamount=(Mixed [dollars (-1)]),+                pcomment="",+                ptype=RegularPosting,+                ptags=[],+                ptransaction=Nothing+              }+             ],+             tpreceding_comment_lines=""+           }+          ,+           txnTieKnot $ Transaction {+             tdate=parsedate "2008/06/03",+             teffectivedate=Nothing,+             tstatus=True,+             tcode="",+             tdescription="eat & shop",+             tcomment="",+             ttags=[],+             tpostings=[+              Posting {+                pstatus=False,+                paccount="expenses:food",+                pamount=(Mixed [dollars 1]),+                pcomment="",+                ptype=RegularPosting,+                ptags=[],+                ptransaction=Nothing+              },+              Posting {+                pstatus=False,+                paccount="expenses:supplies",+                pamount=(Mixed [dollars 1]),+                pcomment="",+                ptype=RegularPosting,+                ptags=[],+                ptransaction=Nothing+              },+              Posting {+                pstatus=False,+                paccount="assets:cash",+                pamount=(missingmixedamt),+                pcomment="",+                ptype=RegularPosting,+                ptags=[],+                ptransaction=Nothing+              }+             ],+             tpreceding_comment_lines=""+           }+          ,+           txnTieKnot $ Transaction {+             tdate=parsedate "2008/12/31",+             teffectivedate=Nothing,+             tstatus=False,+             tcode="",+             tdescription="pay off",+             tcomment="",+             ttags=[],+             tpostings=[+              Posting {+                pstatus=False,+                paccount="liabilities:debts",+                pamount=(Mixed [dollars 1]),+                pcomment="",+                ptype=RegularPosting,+                ptags=[],+                ptransaction=Nothing+              },+              Posting {+                pstatus=False,+                paccount="assets:bank:checking",+                pamount=(Mixed [dollars (-1)]),+                pcomment="",+                ptype=RegularPosting,+                ptags=[],+                ptransaction=Nothing+              }+             ],+             tpreceding_comment_lines=""+           }+          ]+          []+          []+          ""+          nullctx+          []+          (TOD 0 0)++tests_Hledger_Data_Journal = TestList $+    tests_journalAccountInfo+  -- [+  -- "query standard account types" ~:+  --  do+  --   let j = journal1+  --   journalBalanceSheetAccountNames j `is` ["assets","assets:a","equity","equity:q","equity:q:qq","liabilities","liabilities:l"]+  --   journalProfitAndLossAccountNames j `is` ["expenses","expenses:e","income","income:i"]+ -- ]

@@ -20,48 +20,46 @@ import Hledger.Data.AccountName import Hledger.Data.Journal import Hledger.Data.Posting-import Hledger.Data.Matching+import Hledger.Query   instance Show Ledger where     show l = printf "Ledger with %d transactions, %d accounts\n%s"-             (length (jtxns $ journal l) +-              length (jmodifiertxns $ journal l) +-              length (jperiodictxns $ journal l))-             (length $ accountnames l)-             (showtree $ accountnametree l)+             (length (jtxns $ ledgerJournal l) ++              length (jmodifiertxns $ ledgerJournal l) ++              length (jperiodictxns $ ledgerJournal l))+             (length $ ledgerAccountNames l)+             (showtree $ ledgerAccountNameTree l)  nullledger :: Ledger nullledger = Ledger{-      journal = nulljournal,-      accountnametree = nullaccountnametree,-      accountmap = fromList []+      ledgerJournal = nulljournal,+      ledgerAccountNameTree = nullaccountnametree,+      ledgerAccountMap = fromList []     }  -- | Filter a journal's transactions as specified, and then process them -- to derive a ledger containing all balances, the chart of accounts, -- canonicalised commodities etc.-journalToLedger :: FilterSpec -> Journal -> Ledger-journalToLedger fs j = nullledger{journal=j',accountnametree=t,accountmap=m}-    where j' = filterJournalPostings fs{depth=Nothing} j-          (t, m) = journalAccountInfo j'---- | Filter a journal's transactions as specified, and then process them--- to derive a ledger containing all balances, the chart of accounts,--- canonicalised commodities etc.--- Like journalToLedger but uses the new matchers.-journalToLedger2 :: Matcher -> Journal -> Ledger-journalToLedger2 m j = nullledger{journal=j',accountnametree=t,accountmap=amap}-    where j' = filterJournalPostings2 m j+journalToLedger :: Query -> Journal -> Ledger+journalToLedger q j = nullledger{ledgerJournal=j',ledgerAccountNameTree=t,ledgerAccountMap=amap}+    where j' = filterJournalPostings q j           (t, amap) = journalAccountInfo j' +tests_journalToLedger = [+ "journalToLedger" ~: do+  assertEqual "" (0) (length $ ledgerPostings $ journalToLedger Any nulljournal)+  assertEqual "" (11) (length $ ledgerPostings $ journalToLedger Any samplejournal)+  assertEqual "" (6) (length $ ledgerPostings $ journalToLedger (Depth 2) samplejournal)+ ]+ -- | List a ledger's account names. ledgerAccountNames :: Ledger -> [AccountName]-ledgerAccountNames = drop 1 . flatten . accountnametree+ledgerAccountNames = drop 1 . flatten . ledgerAccountNameTree  -- | Get the named account from a ledger. ledgerAccount :: Ledger -> AccountName -> Account-ledgerAccount l a = findWithDefault nullacct a $ accountmap l+ledgerAccount l a = findWithDefault nullacct a $ ledgerAccountMap l  -- | List a ledger's accounts, in tree order ledgerAccounts :: Ledger -> [Account]@@ -77,20 +75,20 @@  -- | Accounts in ledger whose name matches the pattern, in tree order. ledgerAccountsMatching :: [String] -> Ledger -> [Account]-ledgerAccountsMatching pats = filter (matchpats pats . aname) . accounts+ledgerAccountsMatching pats = filter (matchpats pats . aname) . ledgerAccounts  -- | List a ledger account's immediate subaccounts ledgerSubAccounts :: Ledger -> Account -> [Account] ledgerSubAccounts l Account{aname=a} = -    map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ accountnames l+    map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ ledgerAccountNames l  -- | List a ledger's postings, in the order parsed. ledgerPostings :: Ledger -> [Posting]-ledgerPostings = journalPostings . journal+ledgerPostings = journalPostings . ledgerJournal  -- | Get a ledger's tree of accounts to the specified depth. ledgerAccountTree :: Int -> Ledger -> Tree Account-ledgerAccountTree depth l = treemap (ledgerAccount l) $ treeprune depth $ accountnametree l+ledgerAccountTree depth l = treemap (ledgerAccount l) $ treeprune depth $ ledgerAccountNameTree l  -- | Get a ledger's tree of accounts rooted at the specified account. ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account)@@ -101,47 +99,10 @@ ledgerDateSpan :: Ledger -> DateSpan ledgerDateSpan = postingsDateSpan . ledgerPostings --- | Convenience aliases.-accountnames :: Ledger -> [AccountName]-accountnames = ledgerAccountNames--account :: Ledger -> AccountName -> Account-account = ledgerAccount--accounts :: Ledger -> [Account]-accounts = ledgerAccounts--topaccounts :: Ledger -> [Account]-topaccounts = ledgerTopAccounts--accountsmatching :: [String] -> Ledger -> [Account]-accountsmatching = ledgerAccountsMatching--subaccounts :: Ledger -> Account -> [Account]-subaccounts = ledgerSubAccounts--postings :: Ledger -> [Posting]-postings = ledgerPostings--commodities :: Ledger -> Map String Commodity-commodities = journalCanonicalCommodities . journal--accounttree :: Int -> Ledger -> Tree Account-accounttree = ledgerAccountTree--accounttreeat :: Ledger -> Account -> Maybe (Tree Account)-accounttreeat = ledgerAccountTreeAt---- datespan :: Ledger -> DateSpan--- datespan = ledgerDateSpan--rawdatespan :: Ledger -> DateSpan-rawdatespan = journalDateSpan . journal--ledgeramounts :: Ledger -> [MixedAmount]-ledgeramounts = journalAmounts . journal+-- | All commodities used in this ledger, as a map keyed by symbol.+ledgerCommodities :: Ledger -> Map String Commodity+ledgerCommodities = journalCanonicalCommodities . ledgerJournal -tests_Hledger_Data_Ledger = TestList- [- ]+tests_Hledger_Data_Ledger = TestList $+    tests_journalToLedger 

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

@@ -1,14 +1,47 @@ {-| -A 'Posting' represents a 'MixedAmount' being added to or subtracted from a-single 'Account'.  Each 'Transaction' contains two or more postings which-should add up to 0. Postings also reference their parent transaction, so-we can get a date or description for a posting (from the transaction).-Strictly speaking, \"entry\" is probably a better name for these.+A 'Posting' represents a change (by some 'MixedAmount') of the balance in+some 'Account'.  Each 'Transaction' contains two or more postings which+should add up to 0. Postings reference their parent transaction, so we can+look up the date or description there.  -} -module Hledger.Data.Posting+module Hledger.Data.Posting (+  -- * Posting+  nullposting,+  -- * operations+  postingCleared,+  isReal,+  isVirtual,+  isBalancedVirtual,+  isEmptyPosting,+  hasAmount,+  postingAllTags,+  transactionAllTags,+  -- * date operations+  postingDate,+  isPostingInDateSpan,+  postingsDateSpan,+  -- * account name operations+  accountNamesFromPostings,+  accountNamePostingType,+  accountNameWithoutPostingType,+  accountNameWithPostingType,+  joinAccountNames,+  concatAccountNames,+  accountNameApplyAliases,+  -- * arithmetic+  sumPostings,+  -- * rendering+  showPosting,+  showPostingForRegister,+  -- * misc.+  postingTagsAsLines,+  tagsAsLines,+  showComment,+  tests_Hledger_Data_Posting+) where import Data.List import Data.Ord@@ -30,8 +63,8 @@ nullposting = Posting False "" nullmixedamt "" RegularPosting [] Nothing  showPosting :: Posting -> String-showPosting (Posting{paccount=a,pamount=amt,pcomment=com,ptype=t}) =-    concatTopPadded [showaccountname a ++ " ", showamount amt, comment]+showPosting p@Posting{paccount=a,pamount=amt,ptype=t} =+    unlines $ [concatTopPadded [showaccountname a ++ " ", showamount amt, showComment (pcomment p)]] ++ postingTagsAsLines p     where       ledger3ishlayout = False       acctnamewidth = if ledger3ishlayout then 25 else 22@@ -41,7 +74,17 @@                           VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)                           _ -> (id,acctnamewidth)       showamount = padleft 12 . showMixedAmount-      comment = if null com then "" else "  ; " ++ com+++postingTagsAsLines :: Posting -> [String]+postingTagsAsLines = tagsAsLines . ptags++tagsAsLines :: [(String, String)] -> [String]+tagsAsLines mds = map (\(k,v) -> "    ; " ++ k++": "++v) mds++showComment :: String -> String+showComment s = if null s then "" else "  ; " ++ s+ -- XXX refactor showPostingForRegister :: Posting -> String showPostingForRegister (Posting{paccount=a,pamount=amt,ptype=t}) =@@ -66,7 +109,7 @@ isBalancedVirtual p = ptype p == BalancedVirtualPosting  hasAmount :: Posting -> Bool-hasAmount = (/= missingamt) . pamount+hasAmount = (/= missingmixedamt) . pamount  accountNamesFromPostings :: [Posting] -> [AccountName] accountNamesFromPostings = nub . map paccount@@ -86,6 +129,14 @@                     then True                     else maybe False tstatus $ ptransaction p +-- | Tags for this posting including any inherited from its parent transaction.+postingAllTags :: Posting -> [Tag]+postingAllTags p = ptags p ++ maybe [] transactionAllTags (ptransaction p)++-- | Tags for this transaction including any inherited from above, when that is implemented.+transactionAllTags :: Transaction -> [Tag]+transactionAllTags t = ttags t+ -- | Does this posting fall within the given date span ? isPostingInDateSpan :: DateSpan -> Posting -> Bool isPostingInDateSpan s = spanContainsDate s . postingDate@@ -93,8 +144,8 @@ isEmptyPosting :: Posting -> Bool isEmptyPosting = isZeroMixedAmount . pamount --- | Get the minimal date span which contains all the postings, or--- DateSpan Nothing Nothing if there are none.+-- | Get the minimal date span which contains all the postings, or the+-- null date span if there are none. postingsDateSpan :: [Posting] -> DateSpan postingsDateSpan [] = DateSpan Nothing Nothing postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps')

@@ -81,7 +81,7 @@             tcode         = "",             tdescription  = showtime itod ++ "-" ++ showtime otod,             tcomment      = "",-            tmetadata     = [],+            ttags     = [],             tpostings = ps,             tpreceding_comment_lines=""           }@@ -95,7 +95,7 @@       hrs      = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc       amount   = Mixed [hours hrs]       ps       = [Posting{pstatus=False,paccount=acctname,pamount=amount,-                          pcomment="",ptype=VirtualPosting,pmetadata=[],ptransaction=Just t}]+                          pcomment="",ptype=VirtualPosting,ptags=[],ptransaction=Just t}]  tests_Hledger_Data_TimeLog = TestList [ 

@@ -1,12 +1,39 @@ {-| -A 'Transaction' consists of two or more related 'Posting's which balance-to zero, representing a movement of some commodity(ies) between accounts,-plus a date and optional metadata like description and cleared status.+A 'Transaction' represents a movement of some commodity(ies) between two+or more accounts. It consists of multiple account 'Posting's which balance+to zero, a date, and optional extras like description, cleared status, and+tags.  -} -module Hledger.Data.Transaction+module Hledger.Data.Transaction (+  -- * Transaction+  nulltransaction,+  txnTieKnot,+  -- settxn,+  -- * operations+  showAccountName,+  hasRealPostings,+  realPostings,+  virtualPostings,+  balancedVirtualPostings,+  transactionsPostings,+  isTransactionBalanced,+  -- nonzerobalanceerror,+  -- * date operations+  transactionActualDate,+  transactionEffectiveDate,+  journalTransactionWithDate,+  -- * arithmetic+  transactionPostingBalances,+  balanceTransaction,+  -- * rendering+  showTransaction,+  showTransactionUnelided,+  -- * misc.+  tests_Hledger_Data_Transaction+) where import Data.List import Data.Maybe@@ -38,7 +65,7 @@                     tcode="",                      tdescription="",                      tcomment="",-                    tmetadata=[],+                    ttags=[],                     tpostings=[],                     tpreceding_comment_lines=""                   }@@ -65,36 +92,114 @@ showTransactionUnelided :: Transaction -> String showTransactionUnelided = showTransaction' False +tests_showTransactionUnelided = [+   "showTransactionUnelided" ~: do+    let t `gives` s = assertEqual "" s (showTransactionUnelided t)+    nulltransaction `gives` "0000/01/01\n\n"+    nulltransaction{+      tdate=parsedate "2012/05/14",+      teffectivedate=Just $ parsedate "2012/05/15",+      tstatus=False,+      tcode="code",+      tdescription="desc",+      tcomment="tcomment1\ntcomment2\n",+      ttags=[("ttag1","val1")],+      tpostings=[+        nullposting{+          pstatus=True,+          paccount="a",+          pamount=Mixed [dollars 1, hours 2],+          pcomment="pcomment1\npcomment2\n",+          ptype=RegularPosting,+          ptags=[("ptag1","val1"),("ptag2","val2")]+          }+       ]+      }+      `gives` unlines [+      "2012/05/14=2012/05/15 (code) desc  ; tcomment1",+      "    ; tcomment2",+      "    ; ttag1: val1",+      "                $1.00",+      "    * a          2.0h  ; pcomment1",+      "    ; pcomment2",+      "    ; ptag1: val1",+      "    ; ptag2: val2",+      ""+      ]+ ]++-- XXX overlaps showPosting showTransaction' :: Bool -> Transaction -> String showTransaction' elide t =-    unlines $ [description] ++ showpostings (tpostings t) ++ [""]+    unlines $ [descriptionline]+              ++ commentlines+              ++ (tagsAsLines $ ttags t)+              ++ (postingsAsLines elide t (tpostings t))+              ++ [""]     where-      description = concat [date, status, code, desc, comment]+      descriptionline = rstrip $ concat [date, status, code, desc, firstcomment]       date = showdate (tdate t) ++ maybe "" showedate (teffectivedate t)       showdate = printf "%-10s" . showDate       showedate = printf "=%s" . showdate       status = if tstatus t then " *" else ""       code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else ""       desc = if null d then "" else " " ++ d where d = tdescription t-      comment = if null c then "" else "  ; " ++ c where c = tcomment t-      showpostings ps-          | elide && length ps > 1 && isTransactionBalanced Nothing t -- imprecise balanced check-              = map showposting (init ps) ++ [showpostingnoamt (last ps)]-          | otherwise = map showposting ps-          where-            showpostingnoamt p = rstrip $ showacct p ++ "              " ++ showcomment (pcomment p)-            showposting p = concatTopPadded [showacct p-                                            ,"  "-                                            ,showamt (pamount p)-                                            ,showcomment (pcomment p)-                                            ]-            showacct p = "    " ++ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p))-                where w = maximum $ map (length . paccount) ps-                      showstatus p = if pstatus p then "* " else ""-            showamt =-                padleft 12 . showMixedAmount-            showcomment s = if null s then "" else "  ; "++s+      (firstcomment, commentlines) = commentLines $ tcomment t +-- Render a transaction or posting's comment as indented & prefixed comment lines.+commentLines :: String -> (String, [String])+commentLines s+    | null s = ("", [])+    | otherwise = ("  ; " ++ first, map (indent . ("; "++)) rest)+    where (first:rest) = lines s++postingsAsLines :: Bool -> Transaction -> [Posting] -> [String]+postingsAsLines elide t ps+    | elide && length ps > 1 && isTransactionBalanced Nothing t -- imprecise balanced check+       = (concatMap (postingAsLines False ps) $ init ps) ++ postingAsLines True ps (last ps)+    | otherwise = concatMap (postingAsLines False ps) ps++postingAsLines :: Bool -> [Posting] -> Posting -> [String]+postingAsLines elideamount ps p =+    postinglines+    ++ commentlines+    ++ tagsAsLines (ptags p)+  where+    postinglines = map rstrip $ lines $ concatTopPadded [showacct p, "  ", amount, firstcomment]+    amount = if elideamount then "" else showamt (pamount p)+    (firstcomment, commentlines) = commentLines $ pcomment p+    showacct p =+      indent $ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p))+        where+          showstatus p = if pstatus p then "* " else ""+          w = maximum $ map (length . paccount) ps+    showamt =+        padleft 12 . showMixedAmount++tests_postingAsLines = [+   "postingAsLines" ~: do+    let p `gives` ls = assertEqual "" ls (postingAsLines False [p] p)+    nullposting `gives` ["                 0"]+    nullposting{+      pstatus=True,+      paccount="a",+      pamount=Mixed [dollars 1, hours 2],+      pcomment="pcomment1\npcomment2\n",+      ptype=RegularPosting,+      ptags=[("ptag1","val1"),("ptag2","val2")]+      }+     `gives` [+      "                $1.00",+      "    * a          2.0h  ; pcomment1",+      "    ; pcomment2",+      "    ; ptag1: val1",+      "    ; ptag2: val2"+      ]      + ]++indent :: String -> String+indent = ("    "++)+ -- | Show an account name, clipped to the given width if any, and -- appropriately bracketed/parenthesised for the given posting type. showAccountName :: Maybe Int -> PostingType -> AccountName -> String@@ -232,9 +337,9 @@     where       (rsum, _, bvsum) = transactionPostingBalances t       rmsg | isReallyZeroMixedAmountCost rsum = ""-           | otherwise = "real postings are off by " ++ show (costOfMixedAmount rsum)+           | otherwise = "real postings are off by " ++ showMixedAmount (costOfMixedAmount rsum)       bvmsg | isReallyZeroMixedAmountCost bvsum = ""-            | otherwise = "balanced virtual postings are off by " ++ show (costOfMixedAmount bvsum)+            | otherwise = "balanced virtual postings are off by " ++ showMixedAmount (costOfMixedAmount bvsum)       sep = if not (null rmsg) && not (null bvmsg) then "; " else ""  transactionActualDate :: Transaction -> Day@@ -258,7 +363,10 @@ settxn :: Transaction -> Posting -> Posting settxn t p = p{ptransaction=Just t} -tests_Hledger_Data_Transaction = TestList [+tests_Hledger_Data_Transaction = TestList $ concat [+  tests_postingAsLines,+  tests_showTransactionUnelided,+  [   "showTransaction" ~: do      assertEqual "show a balanced transaction, eliding last amount"        (unlines@@ -318,12 +426,12 @@      assertEqual "show a transaction with one posting and a missing amount"        (unlines         ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries              "+        ,"    expenses:food:groceries"         ,""         ])        (showTransaction         (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" []-         [Posting False "expenses:food:groceries" missingamt "" RegularPosting [] Nothing+         [Posting False "expenses:food:groceries" missingmixedamt "" RegularPosting [] Nothing          ] ""))    ,"showTransaction" ~: do@@ -331,13 +439,13 @@        (unlines         ["2010/01/01 x"         ,"    a        1 @ $2"-        ,"    b              "+        ,"    b"         ,""         ])        (showTransaction         (txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" []          [Posting False "a" (Mixed [Amount unknown 1 (Just $ UnitPrice $ Mixed [Amount dollar{precision=0} 2 Nothing])]) "" RegularPosting [] Nothing-         ,Posting False "b" missingamt "" RegularPosting [] Nothing+         ,Posting False "b" missingmixedamt "" RegularPosting [] Nothing          ] ""))    ,"balanceTransaction" ~: do@@ -350,12 +458,12 @@      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+                            [Posting False "a" missingmixedamt "" RegularPosting [] Nothing,+                             Posting False "b" missingmixedamt "" 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+                            Posting False "b" missingmixedamt "" RegularPosting [] Nothing                            ] "")      assertBool "balanceTransaction allows one missing amount" (isRight e)      assertEqual "balancing amount is inferred"@@ -417,4 +525,4 @@              ] ""      assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced Nothing t) -  ]+  ]]

@@ -69,6 +69,8 @@       separatorpositions :: [Int]  -- ^ positions of separators, counting leftward from decimal point     } deriving (Eq,Ord,Show,Read) +type Quantity = Double+ -- | An amount's price in another commodity may be written as \@ unit -- price or \@\@ total price.  Note although a MixedAmount is used, it -- should be in a single commodity, also the amount should be positive;@@ -78,7 +80,7 @@  data Amount = Amount {       commodity :: Commodity,-      quantity :: Double,+      quantity :: Quantity,       price :: Maybe Price  -- ^ the price for this amount at posting time     } deriving (Eq,Ord) @@ -87,13 +89,15 @@ data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting                    deriving (Eq,Show) +type Tag = (String, String)+ data Posting = Posting {       pstatus :: Bool,       paccount :: AccountName,       pamount :: MixedAmount,-      pcomment :: String,+      pcomment :: String, -- ^ this posting's non-tag comment lines, as a single non-indented string       ptype :: PostingType,-      pmetadata :: [(String,String)],+      ptags :: [Tag],       ptransaction :: Maybe Transaction  -- ^ this posting's parent transaction (co-recursive types).                                         -- Tying this knot gets tedious, Maybe makes it easier/optional.     }@@ -109,8 +113,8 @@       tstatus :: Bool,  -- XXX tcleared ?       tcode :: String,       tdescription :: String,-      tcomment :: String,-      tmetadata :: [(String,String)],+      tcomment :: String, -- ^ this transaction's non-tag comment lines, as a single non-indented string+      ttags :: [Tag],       tpostings :: [Posting],            -- ^ this transaction's postings (co-recursive types).       tpreceding_comment_lines :: String     } deriving (Eq)@@ -173,33 +177,86 @@ -- raise an error. type JournalUpdate = ErrorT String IO (Journal -> Journal) +-- | The id of a data format understood by hledger, eg @journal@ or @csv@.+type Format = String+ -- | A hledger journal reader is a triple of format name, format-detecting -- predicate, and a parser to Journal.-data Reader = Reader {rFormat   :: String-                     ,rDetector :: FilePath -> String -> Bool-                     ,rParser   :: FilePath -> String -> ErrorT String IO Journal-                     }+data Reader = Reader {+     -- name of the format this reader handles+     rFormat   :: Format+     -- 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+    } +instance Show Reader where show r = "Reader for "++rFormat r++-- data format parse/conversion rules++-- currently the only parse (conversion) rules are those for the CSV format+type ParseRules = CsvRules++-- XXX copied from Convert.hs+{- |+A set of data definitions and account-matching patterns sufficient to+convert a particular CSV data file into meaningful journal transactions. See above.+-}+data CsvRules = CsvRules {+      dateField :: Maybe FieldPosition,+      dateFormat :: Maybe String,+      statusField :: Maybe FieldPosition,+      codeField :: Maybe FieldPosition,+      descriptionField :: [FormatString],+      amountField :: Maybe FieldPosition,+      amountInField :: Maybe FieldPosition,+      amountOutField :: Maybe FieldPosition,+      currencyField :: Maybe FieldPosition,+      baseCurrency :: Maybe String,+      accountField :: Maybe FieldPosition,+      account2Field :: Maybe FieldPosition,+      effectiveDateField :: Maybe FieldPosition,+      baseAccount :: AccountName,+      accountRules :: [AccountRule]+} deriving (Show, Eq)++type FieldPosition = Int++type AccountRule = (+   [(String, Maybe String)] -- list of regex match patterns with optional replacements+  ,AccountName              -- account name to use for a transaction matching this rule+  )++-- format strings++data HledgerFormatField =+    AccountField+  | DefaultDateField+  | DescriptionField+  | TotalField+  | DepthSpacerField+  | FieldNo Int+    deriving (Show, Eq)++data FormatString =+    FormatLiteral String+  | FormatField Bool        -- Left justified ?+                (Maybe Int) -- Min width+                (Maybe Int) -- Max width+                HledgerFormatField       -- Field+  deriving (Show, Eq)++ data Ledger = Ledger {-      journal :: Journal,-      accountnametree :: Tree AccountName,-      accountmap :: Map.Map AccountName Account+      ledgerJournal :: Journal,+      ledgerAccountNameTree :: Tree AccountName,+      ledgerAccountMap :: Map.Map AccountName Account     }  data Account = Account {       aname :: AccountName,       apostings :: [Posting],    -- ^ postings in this account       abalance :: MixedAmount    -- ^ sum of postings in this account and subaccounts-    }---- | A generic, pure specification of how to filter (or search) transactions and postings.-data FilterSpec = FilterSpec {-     datespan  :: DateSpan   -- ^ only include if in this date span-    ,cleared   :: Maybe Bool -- ^ only include if cleared\/uncleared\/don't care-    ,real      :: Bool       -- ^ only include if real\/don't care-    ,empty     :: Bool       -- ^ include if empty (ie amount is zero)-    ,acctpats  :: [String]   -- ^ only include if matching these account patterns-    ,descpats  :: [String]   -- ^ only include if matching these description patterns-    ,depth     :: Maybe Int-    } deriving (Show)+    } -- deriving (Eq)  XXX 

@@ -0,0 +1,574 @@+{-|++A general query system for matching things (accounts, postings,+transactions..)  by various criteria, and a parser for query expressions.++-}++module Hledger.Query (+  -- * Query and QueryOpt+  Query(..),+  QueryOpt(..),+  -- * parsing+  parseQuery,+  simplifyQuery,+  filterQuery,+  -- * accessors+  queryIsNull,+  queryIsDepth,+  queryIsDate,+  queryIsStartDateOnly,+  queryStartDate,+  queryDateSpan,+  queryDepth,+  queryEmpty,+  inAccount,+  inAccountQuery,+  -- * matching+  matchesAccount,+  matchesPosting,+  matchesTransaction,+  -- * tests+  tests_Hledger_Query+)+where+import Data.Either+import Data.List+import Data.Maybe+import Data.Time.Calendar+import Safe (readDef, headDef, headMay)+import Test.HUnit+import Text.ParserCombinators.Parsec++import Hledger.Utils+import Hledger.Data.Types+import Hledger.Data.AccountName+import Hledger.Data.Dates+import Hledger.Data.Posting+import Hledger.Data.Transaction+++-- | A query is a composition of search criteria, which can be used to+-- match postings, transactions, accounts and more.+data Query = Any              -- ^ always match+           | None             -- ^ never match+           | Not Query        -- ^ negate this match+           | Or [Query]       -- ^ match if any of these match+           | And [Query]      -- ^ match if all of these match+           | Desc String      -- ^ match if description matches this regexp+           | Acct String      -- ^ match postings whose account matches this regexp+           | Date DateSpan    -- ^ match if actual date in this date span+           | EDate DateSpan   -- ^ match if effective date in this date span+           | Status Bool      -- ^ match if cleared status has this value+           | Real Bool        -- ^ match if "realness" (involves a real non-virtual account ?) has this value+           | Empty Bool       -- ^ if true, show zero-amount postings/accounts which are usually not shown+                              --   more of a query option than a query criteria ?+           | Depth Int        -- ^ match if account depth is less than or equal to this value+           | Tag String (Maybe String)  -- ^ match if a tag with this exact name, and with value+                                        -- matching the regexp if provided, exists+    deriving (Show, Eq)++-- | A query option changes a query's/report's behaviour and output in some way.+data QueryOpt = QueryOptInAcctOnly AccountName  -- ^ show an account register focussed on this account+              | QueryOptInAcct AccountName      -- ^ as above but include sub-accounts in the account register+           -- | QueryOptCostBasis      -- ^ show amounts converted to cost where possible+           -- | QueryOptEffectiveDate  -- ^ show effective dates instead of actual dates+    deriving (Show, Eq)++-- parsing++-- -- | A query restricting the account(s) to be shown in the sidebar, if any.+-- -- Just looks at the first query option.+-- showAccountMatcher :: [QueryOpt] -> Maybe Query+-- showAccountMatcher (QueryOptInAcctSubsOnly a:_) = Just $ Acct True $ accountNameToAccountRegex a+-- showAccountMatcher _ = Nothing+++-- | Convert a query expression containing zero or more space-separated+-- terms to a query and zero or more query options. A query term is either:+--+-- 1. a search pattern, which matches on one or more fields, eg:+--+--      acct:REGEXP     - match the account name with a regular expression+--      desc:REGEXP     - match the transaction description+--      date:PERIODEXP  - match the date with a period expression+--+--    The prefix indicates the field to match, or if there is no prefix+--    account name is assumed.+--+-- 2. a query option, which modifies the reporting behaviour in some+--    way. There is currently one of these, which may appear only once:+--+--      inacct:FULLACCTNAME+--+-- The usual shell quoting rules are assumed. When a pattern contains+-- whitespace, it (or the whole term including prefix) should be enclosed+-- in single or double quotes.+--+-- Period expressions may contain relative dates, so a reference date is+-- required to fully parse these.+--+-- Multiple terms are combined as follows:+-- 1. multiple account patterns are OR'd together+-- 2. multiple description patterns are OR'd together+-- 3. then all terms are AND'd together+parseQuery :: Day -> String -> (Query,[QueryOpt])+parseQuery d s = (q, opts)+  where+    terms = words'' prefixes s+    (pats, opts) = partitionEithers $ map (parseQueryTerm d) terms+    (descpats, pats') = partition queryIsDesc pats+    (acctpats, otherpats) = partition queryIsAcct pats'+    q = simplifyQuery $ And $ [Or acctpats, Or descpats] ++ otherpats++tests_parseQuery = [+  "parseQuery" ~: do+    let d = nulldate -- parsedate "2011/1/1"+    parseQuery d "acct:'expenses:autres d\233penses' desc:b" `is` (And [Acct "expenses:autres d\233penses", Desc "b"], [])+    parseQuery d "inacct:a desc:\"b b\"" `is` (Desc "b b", [QueryOptInAcct "a"])+    parseQuery d "inacct:a inacct:b" `is` (Any, [QueryOptInAcct "a", QueryOptInAcct "b"])+    parseQuery d "desc:'x x'" `is` (Desc "x x", [])+    parseQuery d "'a a' 'b" `is` (Or [Acct "a a",Acct "'b"], [])+    parseQuery d "\"" `is` (Acct "\"", [])+ ]++-- XXX+-- | Quote-and-prefix-aware version of words - don't split on spaces which+-- are inside quotes, including quotes which may have one of the specified+-- prefixes in front, and maybe an additional not: prefix in front of that.+words'' :: [String] -> String -> [String]+words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX+    where+      maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, quotedPattern, pattern] `sepBy` many1 spacenonewline+      prefixedQuotedPattern = do+        not' <- fromMaybe "" `fmap` (optionMaybe $ string "not:")+        let allowednexts | null not' = prefixes+                         | otherwise = prefixes ++ [""]+        next <- choice' $ map string allowednexts+        let prefix = not' ++ next+        p <- quotedPattern+        return $ prefix ++ stripquotes p+      quotedPattern = do+        p <- between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\""+        return $ stripquotes p+      pattern = many (noneOf " \n\r")++tests_words'' = [+   "words''" ~: do+    assertEqual "1" ["a","b"]        (words'' [] "a b")+    assertEqual "2" ["a b"]          (words'' [] "'a b'")+    assertEqual "3" ["not:a","b"]    (words'' [] "not:a b")+    assertEqual "4" ["not:a b"]    (words'' [] "not:'a b'")+    assertEqual "5" ["not:a b"]    (words'' [] "'not:a b'")+    assertEqual "6" ["not:desc:a b"]    (words'' ["desc:"] "not:desc:'a b'")+    let s `gives` r = assertEqual "" r (words'' prefixes s)+    "\"acct:expenses:autres d\233penses\"" `gives` ["acct:expenses:autres d\233penses"]+    "\"" `gives` ["\""]+ ]++-- XXX+-- keep synced with patterns below, excluding "not"+prefixes = map (++":") [+     "inacctonly"+    ,"inacct"+    ,"desc"+    ,"acct"+    ,"date"+    ,"edate"+    ,"status"+    ,"real"+    ,"empty"+    ,"depth"+    ,"tag"+    ]++defaultprefix = "acct"++-- -- | Parse the query string as a boolean tree of match patterns.+-- parseQueryTerm :: String -> Query+-- parseQueryTerm s = either (const (Any)) id $ runParser query () "" $ lexmatcher s++-- lexmatcher :: String -> [String]+-- lexmatcher s = words' s++-- query :: GenParser String () Query+-- query = undefined++-- | Parse a single query term as either a query or a query option.+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+parseQueryTerm d ('n':'o':'t':':':s) = case parseQueryTerm d s of+                                       Left m  -> Left $ Not m+                                       Right _ -> Left Any -- not:somequeryoption will be ignored+parseQueryTerm _ ('d':'e':'s':'c':':':s) = Left $ Desc s+parseQueryTerm _ ('a':'c':'c':'t':':':s) = Left $ Acct s+parseQueryTerm d ('d':'a':'t':'e':':':s) =+        case parsePeriodExpr d s of Left _ -> Left None -- XXX should warn+                                    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 $ EDate span+parseQueryTerm _ ('s':'t':'a':'t':'u':'s':':':s) = Left $ Status $ parseStatus s+parseQueryTerm _ ('r':'e':'a':'l':':':s) = Left $ Real $ parseBool s+parseQueryTerm _ ('e':'m':'p':'t':'y':':':s) = Left $ Empty $ parseBool s+parseQueryTerm _ ('d':'e':'p':'t':'h':':':s) = Left $ Depth $ readDef 0 s+parseQueryTerm _ ('t':'a':'g':':':s) = Left $ Tag n v where (n,v) = parseTag s+parseQueryTerm _ "" = Left $ Any+parseQueryTerm d s = parseQueryTerm d $ defaultprefix++":"++s++tests_parseQueryTerm = [+  "parseQueryTerm" ~: do+    let s `gives` r = parseQueryTerm nulldate s `is` r+    "a" `gives` (Left $ Acct "a")+    "acct:expenses:autres d\233penses" `gives` (Left $ Acct "expenses:autres d\233penses")+    "not:desc:a b" `gives` (Left $ Not $ Desc "a b")+    "status:1" `gives` (Left $ Status True)+    "status:0" `gives` (Left $ Status False)+    "status:" `gives` (Left $ Status False)+    "real:1" `gives` (Left $ Real True)+    "date:2008" `gives` (Left $ Date $ DateSpan (Just $ parsedate "2008/01/01") (Just $ parsedate "2009/01/01"))+    "date:from 2012/5/17" `gives` (Left $ Date $ DateSpan (Just $ parsedate "2012/05/17") Nothing)+    "inacct:a" `gives` (Right $ QueryOptInAcct "a")+    "tag:a" `gives` (Left $ Tag "a" Nothing)+    "tag:a=some value" `gives` (Left $ Tag "a" (Just "some value"))+ ]++parseTag :: String -> (String, Maybe String)+parseTag s | '=' `elem` s = (n, Just $ tail v)+           | 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.+parseStatus :: String -> Bool+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".+parseBool :: String -> Bool+parseBool s = s `elem` truestrings++truestrings :: [String]+truestrings = ["1","t","true"]++simplifyQuery :: Query -> Query+simplifyQuery q =+  let q' = simplify q+  in if q' == q then q else simplifyQuery q'+  where+    simplify (And []) = Any+    simplify (And [q]) = simplify q+    simplify (And qs) | same qs = simplify $ head qs+                      | any (==None) qs = None+                      | all queryIsDate qs = Date $ spansIntersect $ mapMaybe queryTermDateSpan qs+                      | otherwise = And $ concat $ [map simplify dateqs, map simplify otherqs]+                      where (dateqs, otherqs) = partition queryIsDate $ filter (/=Any) qs+    simplify (Or []) = Any+    simplify (Or [q]) = simplifyQuery q+    simplify (Or qs) | same qs = simplify $ head qs+                     | any (==Any) qs = Any+                     -- all queryIsDate qs = Date $ spansUnion $ mapMaybe queryTermDateSpan qs  ?+                     | otherwise = Or $ map simplify $ filter (/=None) qs+    simplify (Date (DateSpan Nothing Nothing)) = Any+    simplify q = q++tests_simplifyQuery = [+ "simplifyQuery" ~: do+  let q `gives` r = assertEqual "" r (simplifyQuery q)+  Or [Acct "a"] `gives` Acct "a"+  Or [Any,None] `gives` Any+  And [Any,None] `gives` None+  And [Any,Any] `gives` Any+  And [Acct "b",Any] `gives` Acct "b"+  And [Any,And [Date (DateSpan Nothing Nothing)]] `gives` Any+  And [Date (DateSpan Nothing (Just $ parsedate "2013-01-01")), Date (DateSpan (Just $ parsedate "2012-01-01") Nothing)]+      `gives` Date (DateSpan (Just $ parsedate "2012-01-01") (Just $ parsedate "2013-01-01"))+  And [Or [],Or [Desc "b b"]] `gives` Desc "b b"+ ]++same [] = True+same (a:as) = all (a==) as++-- | Remove query terms (or whole sub-expressions) not matching the given+-- predicate from this query.  XXX Semantics not yet clear.+filterQuery :: (Query -> Bool) -> Query -> Query+filterQuery p (And qs) = And $ filter p qs+filterQuery p (Or qs) = Or $ filter p qs+-- filterQuery p (Not q) = Not $ filterQuery p q+filterQuery p q = if p q then q else Any++tests_filterQuery = [+ "filterQuery" ~: do+  let (q,p) `gives` r = assertEqual "" r (filterQuery p q)+  (Any, queryIsDepth) `gives` Any+  (Depth 1, queryIsDepth) `gives` Depth 1+  -- (And [Date nulldatespan, Not (Or [Any, Depth 1])], queryIsDepth) `gives` And [Not (Or [Depth 1])]+ ]++-- * accessors++-- | Does this query match everything ?+queryIsNull :: Query -> Bool+queryIsNull Any = True+queryIsNull (And []) = True+queryIsNull (Not (Or [])) = True+queryIsNull _ = False++queryIsDepth :: Query -> Bool+queryIsDepth (Depth _) = True+queryIsDepth _ = False++queryIsDate :: Query -> Bool+queryIsDate (Date _) = True+queryIsDate _ = False++queryIsDesc :: Query -> Bool+queryIsDesc (Desc _) = True+queryIsDesc _ = False++queryIsAcct :: Query -> Bool+queryIsAcct (Acct _) = True+queryIsAcct _ = False++-- | Does this query specify a start date and nothing else (that would+-- filter postings prior to the date) ?+-- When the flag is true, look for a starting effective date instead.+queryIsStartDateOnly :: Bool -> Query -> Bool+queryIsStartDateOnly _ Any = False+queryIsStartDateOnly _ None = False+queryIsStartDateOnly effective (Or ms) = and $ map (queryIsStartDateOnly effective) ms+queryIsStartDateOnly effective (And ms) = and $ map (queryIsStartDateOnly effective) ms+queryIsStartDateOnly False (Date (DateSpan (Just _) _)) = True+queryIsStartDateOnly True (EDate (DateSpan (Just _) _)) = True+queryIsStartDateOnly _ _ = False++-- | What start date (or effective date) does this query specify, if any ?+-- For OR expressions, use the earliest of the dates. NOT is ignored.+queryStartDate :: Bool -> Query -> Maybe Day+queryStartDate effective (Or ms) = earliestMaybeDate $ map (queryStartDate effective) ms+queryStartDate effective (And ms) = latestMaybeDate $ map (queryStartDate effective) ms+queryStartDate False (Date (DateSpan (Just d) _)) = Just d+queryStartDate True (EDate (DateSpan (Just d) _)) = Just d+queryStartDate _ _ = Nothing++queryTermDateSpan (Date span) = Just span+queryTermDateSpan _ = Nothing++-- | What date span (or effective date span) does this query specify ?+-- For OR expressions, use the widest possible span. NOT is ignored.+queryDateSpan :: Bool -> Query -> DateSpan+queryDateSpan effective q = spansUnion $ queryDateSpans effective q++-- | Extract all date (or effective date) spans specified in this query.+-- NOT is ignored.+queryDateSpans :: Bool -> Query -> [DateSpan]+queryDateSpans effective (Or qs) = concatMap (queryDateSpans effective) qs+queryDateSpans effective (And qs) = concatMap (queryDateSpans effective) qs+queryDateSpans False (Date span) = [span]+queryDateSpans True (EDate span) = [span]+queryDateSpans _ _ = []++-- | What is the earliest of these dates, where Nothing is earliest ?+earliestMaybeDate :: [Maybe Day] -> Maybe Day+earliestMaybeDate = headDef Nothing . sortBy compareMaybeDates++-- | What is the latest of these dates, where Nothing is earliest ?+latestMaybeDate :: [Maybe Day] -> Maybe Day+latestMaybeDate = headDef Nothing . sortBy (flip compareMaybeDates)++-- | Compare two maybe dates, Nothing is earliest.+compareMaybeDates :: Maybe Day -> Maybe Day -> Ordering+compareMaybeDates Nothing Nothing = EQ+compareMaybeDates Nothing (Just _) = LT+compareMaybeDates (Just _) Nothing = GT+compareMaybeDates (Just a) (Just b) = compare a b++-- | The depth limit this query specifies, or a large number if none.+queryDepth :: Query -> Int+queryDepth q = case queryDepth' q of [] -> 99999+                                     ds -> minimum ds+  where+    queryDepth' (Depth d) = [d]+    queryDepth' (Or qs) = concatMap queryDepth' qs+    queryDepth' (And qs) = concatMap queryDepth' qs+    queryDepth' _ = []++-- | The empty (zero amount) status specified by this query, defaulting to false.+queryEmpty :: Query -> Bool+queryEmpty = headDef False . queryEmpty'+  where+    queryEmpty' (Empty v) = [v]+    queryEmpty' (Or qs) = concatMap queryEmpty' qs+    queryEmpty' (And qs) = concatMap queryEmpty' qs+    queryEmpty' _ = []++-- -- | The "include empty" option specified by this query, defaulting to false.+-- emptyQueryOpt :: [QueryOpt] -> Bool+-- emptyQueryOpt = headDef False . emptyQueryOpt'+--   where+--     emptyQueryOpt' [] = False+--     emptyQueryOpt' (QueryOptEmpty v:_) = v+--     emptyQueryOpt' (_:vs) = emptyQueryOpt' vs++-- | The account we are currently focussed on, if any, and whether subaccounts are included.+-- Just looks at the first query option.+inAccount :: [QueryOpt] -> Maybe (AccountName,Bool)+inAccount [] = Nothing+inAccount (QueryOptInAcctOnly a:_) = Just (a,False)+inAccount (QueryOptInAcct a:_) = Just (a,True)++-- | A query for the account(s) we are currently focussed on, if any.+-- Just looks at the first query option.+inAccountQuery :: [QueryOpt] -> Maybe Query+inAccountQuery [] = Nothing+inAccountQuery (QueryOptInAcctOnly a:_) = Just $ Acct $ accountNameToAccountOnlyRegex a+inAccountQuery (QueryOptInAcct a:_) = Just $ Acct $ accountNameToAccountRegex a++-- -- | Convert a query to its inverse.+-- negateQuery :: Query -> Query+-- negateQuery =  Not++-- matching++-- | Does the match expression match this account ?+-- A matching in: clause is also considered a match.+matchesAccount :: Query -> AccountName -> Bool+matchesAccount (None) _ = False+matchesAccount (Not m) a = not $ matchesAccount m a+matchesAccount (Or ms) a = any (`matchesAccount` a) ms+matchesAccount (And ms) a = all (`matchesAccount` a) ms+matchesAccount (Acct r) a = regexMatchesCI r a+matchesAccount (Depth d) a = accountNameLevel a <= d+matchesAccount (Tag _ _) _ = False+matchesAccount _ _ = True++tests_matchesAccount = [+   "matchesAccount" ~: do+    assertBool "positive acct match" $ matchesAccount (Acct "b:c") "a:bb:c:d"+    -- assertBool "acct should match at beginning" $ not $ matchesAccount (Acct True "a:b") "c:a:b"+    let q `matches` a = assertBool "" $ q `matchesAccount` a+    Depth 2 `matches` "a:b"+    assertBool "" $ Depth 2 `matchesAccount` "a"+    assertBool "" $ Depth 2 `matchesAccount` "a:b"+    assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c"+    assertBool "" $ Date nulldatespan `matchesAccount` "a"+    assertBool "" $ EDate nulldatespan `matchesAccount` "a"+    assertBool "" $ not $ (Tag "a" Nothing) `matchesAccount` "a"+ ]++-- | Does the match expression match this posting ?+matchesPosting :: Query -> Posting -> Bool+matchesPosting (Not q) p = not $ q `matchesPosting` p+matchesPosting (Any) _ = True+matchesPosting (None) _ = False+matchesPosting (Or qs) p = any (`matchesPosting` p) qs+matchesPosting (And qs) p = all (`matchesPosting` p) qs+matchesPosting (Desc r) p = regexMatchesCI r $ maybe "" tdescription $ ptransaction p+matchesPosting (Acct r) p = regexMatchesCI r $ paccount p+matchesPosting (Date span) p =+    case d of Just d'  -> spanContainsDate span d'+              Nothing -> False+    where d = maybe Nothing (Just . tdate) $ ptransaction p+matchesPosting (EDate span) p =+    case postingEffectiveDate p of Just d  -> spanContainsDate span d+                                   Nothing -> False+matchesPosting (Status v) p = v == postingCleared p+matchesPosting (Real v) p = v == isReal p+matchesPosting (Depth d) Posting{paccount=a} = Depth d `matchesAccount` a+-- matchesPosting (Empty v) Posting{pamount=a} = v == isZeroMixedAmount a+-- matchesPosting (Empty False) Posting{pamount=a} = True+-- matchesPosting (Empty True) Posting{pamount=a} = isZeroMixedAmount a+matchesPosting (Empty _) _ = True+matchesPosting (Tag n Nothing) p = isJust $ lookupTagByName n $ postingAllTags p+matchesPosting (Tag n (Just v)) p = isJust $ lookupTagByNameAndValue (n,v) $ postingAllTags p+-- matchesPosting _ _ = False++tests_matchesPosting = [+   "matchesPosting" ~: do+    -- matching posting status..+    assertBool "positive match on true posting status"  $+                   (Status True)  `matchesPosting` nullposting{pstatus=True}+    assertBool "negative match on true posting status"  $+               not $ (Not $ Status True)  `matchesPosting` nullposting{pstatus=True}+    assertBool "positive match on false posting status" $+                   (Status False) `matchesPosting` nullposting{pstatus=False}+    assertBool "negative match on false posting status" $+               not $ (Not $ Status False) `matchesPosting` nullposting{pstatus=False}+    assertBool "positive match on true posting status acquired from transaction" $+                   (Status True) `matchesPosting` nullposting{pstatus=False,ptransaction=Just nulltransaction{tstatus=True}}+    assertBool "real:1 on real posting" $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting}+    assertBool "real:1 on virtual posting fails" $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting}+    assertBool "real:1 on balanced virtual posting fails" $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting}+    assertBool "" $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"}+    assertBool "" $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting+    assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]}+    assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]}+    assertBool "" $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}+    assertBool "" $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]}+    assertBool "" $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}+    assertBool "" $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]}+    -- a tag match on a posting also sees inherited tags+    assertBool "" $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}}+ ]++-- | Does the match expression match this transaction ?+matchesTransaction :: Query -> Transaction -> Bool+matchesTransaction (Not q) t = not $ q `matchesTransaction` t+matchesTransaction (Any) _ = True+matchesTransaction (None) _ = False+matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs+matchesTransaction (And qs) t = all (`matchesTransaction` t) qs+matchesTransaction (Desc r) t = regexMatchesCI r $ tdescription t+matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t+matchesTransaction (Date span) t = spanContainsDate span $ tdate t+matchesTransaction (EDate span) t = spanContainsDate span $ transactionEffectiveDate t+matchesTransaction (Status v) t = v == tstatus t+matchesTransaction (Real v) t = v == hasRealPostings t+matchesTransaction (Empty _) _ = True+matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t+matchesTransaction (Tag n Nothing) t = isJust $ lookupTagByName n $ transactionAllTags t+matchesTransaction (Tag n (Just v)) t = isJust $ lookupTagByNameAndValue (n,v) $ transactionAllTags t++-- matchesTransaction _ _ = False++tests_matchesTransaction = [+  "matchesTransaction" ~: do+   let q `matches` t = assertBool "" $ q `matchesTransaction` t+   Any `matches` nulltransaction+   assertBool "" $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"}+   assertBool "" $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x x"}+   -- see posting for more tag tests+   assertBool "" $ (Tag "foo" (Just "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]}+   -- a tag match on a transaction usually ignores posting tags+   assertBool "" $ not $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]}+ ]++lookupTagByName :: String -> [Tag] -> Maybe Tag+lookupTagByName namepat tags = headMay [(n,v) | (n,v) <- tags, matchTagName namepat n]++lookupTagByNameAndValue :: Tag -> [Tag] -> Maybe Tag+lookupTagByNameAndValue (namepat, valpat) tags = headMay [(n,v) | (n,v) <- tags, matchTagName namepat n, matchTagValue valpat v]++matchTagName :: String -> String -> Bool+matchTagName pat name = pat == name++matchTagValue :: String -> String -> Bool+matchTagValue pat value = regexMatchesCI pat value++postingEffectiveDate :: Posting -> Maybe Day+postingEffectiveDate p = maybe Nothing (Just . transactionEffectiveDate) $ ptransaction p++-- tests++tests_Hledger_Query :: Test+tests_Hledger_Query = TestList $+    tests_simplifyQuery+ ++ tests_words''+ ++ tests_filterQuery+ ++ tests_parseQueryTerm+ ++ tests_parseQuery+ ++ tests_matchesAccount+ ++ tests_matchesPosting+ ++ tests_matchesTransaction+

@@ -1,28 +1,35 @@+{-# LANGUAGE ScopedTypeVariables #-} {-|  -Read hledger data from various data formats, and related utilities.+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+journal data or read journal files. Generally it should not be necessary+to import modules below this one.  -}  module Hledger.Read (-       tests_Hledger_Read,-       readJournalFile,+       -- * Journal reading API+       defaultJournalPath,+       defaultJournal,        readJournal,-       journalFromPathAndString,-       ledgeraccountname,-       myJournalPath,-       myJournal,-       someamount,-       journalenvvar,-       journaldefaultfilename,-       requireJournalFile,-       ensureJournalFile,+       readJournal',+       readJournalFile,+       requireJournalFileExists,+       ensureJournalFileExists,+       -- * Parsers used elsewhere+       accountname,+       amount,+       amount',+       -- * Tests+       samplejournal,+       tests_Hledger_Read, ) where+import qualified Control.Exception as C import Control.Monad.Error-import Data.Either (partitionEithers) import Data.List-import Safe (headDef)+import Data.Maybe import System.Directory (doesFileExist, getHomeDirectory) import System.Environment (getEnv) import System.Exit (exitFailure)@@ -32,70 +39,131 @@ import Text.Printf  import Hledger.Data.Dates (getCurrentDay)-import Hledger.Data.Types (Journal(..), Reader(..))+import Hledger.Data.Types import Hledger.Data.Journal (nullctx) import Hledger.Read.JournalReader as JournalReader import Hledger.Read.TimelogReader as TimelogReader+import Hledger.Read.CsvReader as CsvReader import Hledger.Utils import Prelude hiding (getContents, writeFile)-import Hledger.Utils.UTF8 (getContents, hGetContents, writeFile)+import Hledger.Utils.UTF8IOCompat (getContents, hGetContents, writeFile)  -journalenvvar           = "LEDGER_FILE"-journalenvvar2          = "LEDGER"-journaldefaultfilename  = ".hledger.journal"+journalEnvVar           = "LEDGER_FILE"+journalEnvVar2          = "LEDGER"+journalDefaultFilename  = ".hledger.journal" --- Here are the available readers. The first is the default, used for unknown data formats.+-- The available data file readers, each one handling a particular data+-- format. The first is also used as the default for unknown formats. readers :: [Reader] readers = [   JournalReader.reader  ,TimelogReader.reader+ ,CsvReader.reader  ] -formats   = map rFormat readers+-- | All the data formats we can read.+-- formats = map rFormat readers -readerForFormat :: String -> Maybe Reader+-- | Get the default journal file path specified by the environment.+-- 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 hard-coded default, which is @.hledger.journal@ in the+-- users's home directory (or in the current directory, if we cannot+-- determine a home directory).+defaultJournalPath :: IO String+defaultJournalPath = do+  s <- envJournalPath+  if null s then defaultJournalPath else return s+    where+      envJournalPath =+        getEnv journalEnvVar+         `C.catch` (\(_::C.IOException) -> getEnv journalEnvVar2+                                            `C.catch` (\(_::C.IOException) -> return ""))+      defaultJournalPath = do+                  home <- getHomeDirectory `C.catch` (\(_::C.IOException) -> return "")+                  return $ home </> journalDefaultFilename++-- | Read the default journal file specified by the environment, or raise an error.+defaultJournal :: IO Journal+defaultJournal = defaultJournalPath >>= readJournalFile Nothing Nothing >>= 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++tests_readJournal' = [+  "readJournal' parses sample journal" ~: do+     _ <- samplejournal+     assertBool "" True+ ]++++-- | Read a journal from this string, trying whatever readers seem appropriate:+--+-- - if a format is specified, try that reader only+--+-- - or if one or more readers recognises the file path and data, try those+--+-- - otherwise, try them all.+--+-- A CSV conversion rules file may also be specified for use by the CSV reader.+readJournal :: Maybe Format -> Maybe FilePath -> Maybe FilePath -> String -> IO (Either String Journal)+readJournal format rulesfile path s =+  -- trace (show (format, rulesfile, path)) $+  tryReaders $ readersFor (format, path, s)+  where+    -- try each reader in turn, returning the error of the first if all fail+    tryReaders :: [Reader] -> IO (Either String Journal)+    tryReaders = firstSuccessOrBestError []+      where+        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+          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+        path' = fromMaybe "(string)" path++-- | Which readers are worth trying for this (possibly unspecified) format, filepath, and data ?+readersFor :: (Maybe Format, Maybe FilePath, String) -> [Reader]+readersFor (format,path,s) =+    case format of +     Just f  -> case readerForFormat f of Just r  -> [r]+                                          Nothing -> []+     Nothing -> case path of Nothing  -> readers+                             Just "-" -> readers+                             Just p   -> case readersForPathAndData (p,s) of [] -> readers+                                                                             rs -> rs++-- | Find the (first) reader which can handle the given format, if any.+readerForFormat :: Format -> Maybe Reader readerForFormat s | null rs = Nothing                   | otherwise = Just $ head rs     where        rs = filter ((s==).rFormat) readers :: [Reader] --- | Read a Journal from this string (and file path), auto-detecting the--- data format, or give a useful error string. Tries to parse each known--- data format in turn. If none succeed, gives the error message specific--- to the intended data format, which if not specified is guessed from the--- file suffix and possibly the data.-journalFromPathAndString :: Maybe String -> FilePath -> String -> IO (Either String Journal)-journalFromPathAndString format fp s = do-  let readers' = case format of Just f -> case readerForFormat f of Just r -> [r]-                                                                    Nothing -> []-                                Nothing -> readers-  (errors, journals) <- partitionEithers `fmap` mapM tryReader readers'-  case journals of j:_ -> return $ Right j-                   _   -> return $ Left $ errMsg errors-    where-      tryReader r = (runErrorT . (rParser r) fp) s-      errMsg [] = unknownFormatMsg-      errMsg es = printf "could not parse %s data in %s\n%s" (rFormat r) fp e-          where (r,e) = headDef (head readers, head es) $ filter detects $ zip readers es-                detects (r,_) = (rDetector r) fp s-      unknownFormatMsg = printf "could not parse %sdata in %s" (fmt formats) fp-          where fmt [] = ""-                fmt [f] = f ++ " "-                fmt fs = intercalate ", " (init fs) ++ " or " ++ last fs ++ " "+-- | Find the readers which think they can handle the given file path and data, if any.+readersForPathAndData :: (FilePath,String) -> [Reader]+readersForPathAndData (f,s) = filter (\r -> (rDetector r) f s) readers --- | Read a journal from this file, using the specified data format or--- trying all known formats, or give an error string; also create the file--- if it doesn't exist.-readJournalFile :: Maybe String -> FilePath -> IO (Either String Journal)-readJournalFile format "-" = getContents >>= journalFromPathAndString format "(stdin)"-readJournalFile format f = do-  requireJournalFile f-  withFile f ReadMode $ \h -> hGetContents h >>= journalFromPathAndString format f+-- | 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 Format -> Maybe FilePath -> FilePath -> IO (Either String Journal)+readJournalFile format rulesfile "-" = getContents >>= readJournal format rulesfile (Just "(stdin)")+readJournalFile format rulesfile f = do+  requireJournalFileExists f+  withFile f ReadMode $ \h -> hGetContents h >>= readJournal format rulesfile (Just f)  -- | If the specified journal file does not exist, give a helpful error and quit.-requireJournalFile :: FilePath -> IO ()-requireJournalFile f = do+requireJournalFileExists :: FilePath -> IO ()+requireJournalFileExists f = do   exists <- doesFileExist f   when (not exists) $ do     hPrintf stderr "The hledger journal file \"%s\" was not found.\n" f@@ -104,8 +172,8 @@     exitFailure  -- | Ensure there is a journal file at the given path, creating an empty one if needed.-ensureJournalFile :: FilePath -> IO ()-ensureJournalFile f = do+ensureJournalFileExists :: FilePath -> IO ()+ensureJournalFileExists f = do   exists <- doesFileExist f   when (not exists) $ do     hPrintf stderr "Creating hledger journal file \"%s\".\n" f@@ -119,39 +187,41 @@   d <- getCurrentDay   return $ printf "; journal created %s by hledger\n" (show d) --- | Read a Journal from this string, using the specified data format or--- trying all known formats, or give an error string.-readJournal :: Maybe String -> String -> IO (Either String Journal)-readJournal format s = journalFromPathAndString format "(string)" s---- | 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 = 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+-- tests --- | Read the user's default journal file, or give an error.-myJournal :: IO Journal-myJournal = myJournalPath >>= readJournalFile Nothing >>= either error' return+samplejournal = readJournal' $ unlines+ ["2008/01/01 income"+ ,"    assets:bank:checking  $1"+ ,"    income:salary"+ ,""+ ,"2008/06/01 gift"+ ,"    assets:bank:checking  $1"+ ,"    income:gifts"+ ,""+ ,"2008/06/02 save"+ ,"    assets:bank:saving  $1"+ ,"    assets:bank:checking"+ ,""+ ,"2008/06/03 * eat & shop"+ ,"    expenses:food      $1"+ ,"    expenses:supplies  $1"+ ,"    assets:cash"+ ,""+ ,"2008/12/31 * pay off"+ ,"    liabilities:debts  $1"+ ,"    assets:bank:checking"+ ] -tests_Hledger_Read = TestList-  [+tests_Hledger_Read = TestList $+  tests_readJournal'+  ++ [    tests_Hledger_Read_JournalReader,    tests_Hledger_Read_TimelogReader,+   tests_Hledger_Read_CsvReader, -   "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+   "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+    either error' (assertBool "journal parsing an empty file should give an empty journal" . null . jtxns) jE    ]

@@ -0,0 +1,584 @@+{-|++A reader for the CSV data format. Uses an extra rules file+(<http://hledger.org/MANUAL.html#rules-file-directives>) to help interpret+the data. Example:++@+\"2012\/3\/22\",\"something\",\"10.00\"+\"2012\/3\/23\",\"another\",\"5.50\"+@++and rules file:++@+date-field 0+description-field 1+amount-field 2+base-account assets:bank:checking++SAVINGS+assets:bank:savings+@++-}++module Hledger.Read.CsvReader (+  -- * Reader+  reader,+  -- * Tests+  tests_Hledger_Read_CsvReader+)+where+import Control.Exception hiding (try)+import Control.Monad+import Control.Monad.Error+-- import Test.HUnit+import Data.List+import Data.Maybe+import Data.Ord+import Data.Time.Format (parseTime)+import Safe+import System.Directory (doesFileExist)+import System.FilePath+import System.IO (stderr)+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.Printf (hPrintf)++import Hledger.Data+import Prelude hiding (getContents)+import Hledger.Utils.UTF8IOCompat (getContents)+import Hledger.Utils+import Hledger.Data.FormatStrings as FormatStrings+import Hledger.Read.JournalReader (accountname, amount)+++reader :: Reader+reader = Reader format detect parse++format :: String+format = "csv"++-- | Does the given file path and data look like CSV ?+detect :: FilePath -> String -> Bool+detect f _ = takeExtension f == '.':format++-- | 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+  r <- liftIO $ readJournalFromCsv rulesfile f s+  case r of Left e -> throwError e+            Right j -> return j++nullrules = CsvRules {+      dateField=Nothing,+      dateFormat=Nothing,+      statusField=Nothing,+      codeField=Nothing,+      descriptionField=[],+      amountField=Nothing,+      amountInField=Nothing,+      amountOutField=Nothing,+      currencyField=Nothing,+      baseCurrency=Nothing,+      accountField=Nothing,+      account2Field=Nothing,+      effectiveDateField=Nothing,+      baseAccount="unknown",+      accountRules=[]+}++type CsvRecord = [String]+++-- | Read a Journal from the given CSV data (and filename, used for error+-- messages), or return an error. Proceed as follows:+-- @+-- 1. parse the CSV data+-- 2. identify the name of a file specifying conversion rules: either use+-- the name provided, derive it from the CSV filename, or raise an error+-- if the CSV filename is -.+-- 3. auto-create the rules file with default rules if it doesn't exist+-- 4. parse the rules file+-- 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 mrulesfile csvfile csvdata =+ handle (\e -> return $ Left $ show (e :: IOException)) $ do+  csvparse <- parseCsv csvfile csvdata+  let rs = case csvparse of+                  Left e -> throw $ userError $ show e+                  Right rs -> filter (/= [""]) rs+      badrecords = take 1 $ filter ((< 2).length) rs+      records = case badrecords of+                 []    -> rs+                 (_:_) -> throw $ userError $ "Parse error: at least one CSV record has less than two fields:\n"++(show $ head badrecords)++  let rulesfile = fromMaybe (rulesFileFor csvfile) mrulesfile+  created <- records `seq` (trace "ensureRulesFile" $ ensureRulesFileExists rulesfile)+  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 <- liftM (either (throw.userError.show) id) $ parseCsvRulesFile rulesfile++  let requiredfields = (maxFieldIndex rules + 1)+      badrecords = take 1 $ filter ((< requiredfields).length) records+  return $ case badrecords of+            []    -> Right nulljournal{jtxns=sortBy (comparing tdate) $ map (transactionFromCsvRecord rules) records}+            (_:_) -> Left $ "Parse error: at least one CSV record does not contain a field referenced by the conversion rules file:\n"++(show $ head badrecords)++-- | Ensure there is a conversion rules file at the given path, creating a+-- default one if needed and returning True in this case.+ensureRulesFileExists :: FilePath -> IO Bool+ensureRulesFileExists f = do+  exists <- doesFileExist f+  if exists+   then return False+   else do+     -- note Hledger.Utils.UTF8.* do no line ending conversion on windows,+     -- we currently require unix line endings on all platforms.+     writeFile f newRulesFileContent+     return True++parseCsv :: FilePath -> String -> IO (Either ParseError CSV)+parseCsv path csvdata =+  case path of+    "-" -> liftM (parseCSV "(stdin)") getContents+    _   -> return $ parseCSV path csvdata++-- | The highest (0-based) field index referenced in the field+-- definitions, or -1 if no fields are defined.+maxFieldIndex :: CsvRules -> Int+maxFieldIndex r = maximumDef (-1) $ catMaybes [+                   dateField r+                  ,statusField r+                  ,codeField r+                  ,amountField r+                  ,amountInField r+                  ,amountOutField r+                  ,currencyField r+                  ,accountField r+                  ,account2Field r+                  ,effectiveDateField r+                  ]++-- rulesFileFor :: CliOpts -> FilePath -> FilePath+-- rulesFileFor CliOpts{rules_file_=Just f} _ = f+-- rulesFileFor CliOpts{rules_file_=Nothing} csvfile = replaceExtension csvfile ".rules"+rulesFileFor :: FilePath -> FilePath+rulesFileFor = flip replaceExtension ".rules"++newRulesFileContent :: String+newRulesFileContent = let prognameandversion = "hledger" in+    "# csv conversion rules file generated by " ++ prognameandversion ++ "\n" +++    "# Add rules to this file for more accurate conversion, see\n"+++    "# http://hledger.org/MANUAL.html#convert\n" +++    "\n" +++    "base-account assets:bank:checking\n" +++    "date-field 0\n" +++    "description-field 4\n" +++    "amount-field 1\n" +++    "base-currency $\n" +++    "\n" +++    "# account-assigning rules\n" +++    "\n" +++    "SPECTRUM\n" +++    "expenses:health:gym\n" +++    "\n" +++    "ITUNES\n" +++    "BLKBSTR=BLOCKBUSTER\n" +++    "expenses:entertainment\n" +++    "\n" +++    "(TO|FROM) SAVINGS\n" +++    "assets:bank:savings\n"++-- rules file parser++parseCsvRulesFile :: FilePath -> IO (Either ParseError CsvRules)+parseCsvRulesFile f = do+  s <- readFile 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+  where+    toParseError s = newErrorMessage (Message s) (initialPos "")++parseCsvRules :: FilePath -> String -> Either ParseError CsvRules+parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s++csvrulesfile :: GenParser Char CsvRules CsvRules+csvrulesfile = do+  many blankorcommentline+  many definitions+  r <- getState+  ars <- many accountrule+  many blankorcommentline+  eof+  return r{accountRules=ars}++definitions :: GenParser Char CsvRules ()+definitions = do+  choice' [+    datefield+   ,dateformat+   ,statusfield+   ,codefield+   ,descriptionfield+   ,amountfield+   ,amountinfield+   ,amountoutfield+   ,currencyfield+   ,accountfield+   ,account2field+   ,effectivedatefield+   ,basecurrency+   ,baseaccount+   ,commentline+   ] <?> "definition"+  return ()++datefield = do+  string "date-field"+  many1 spacenonewline+  v <- restofline+  updateState (\r -> r{dateField=readMay v})++effectivedatefield = do+  string "effective-date-field"+  many1 spacenonewline+  v <- restofline+  updateState (\r -> r{effectiveDateField=readMay v})++dateformat = do+  string "date-format"+  many1 spacenonewline+  v <- restofline+  updateState (\r -> r{dateFormat=Just v})++codefield = do+  string "code-field"+  many1 spacenonewline+  v <- restofline+  updateState (\r -> r{codeField=readMay v})++statusfield = do+  string "status-field"+  many1 spacenonewline+  v <- restofline+  updateState (\r -> r{statusField=readMay v})++descriptionFieldValue :: GenParser Char st [FormatString]+descriptionFieldValue = do+--      try (fieldNo <* spacenonewline)+      try fieldNo+  <|> formatStrings+  where+    fieldNo = many1 digit >>= \x -> return [FormatField False Nothing Nothing $ FieldNo $ read x]++descriptionfield = do+  string "description-field"+  many1 spacenonewline+  formatS <- descriptionFieldValue+  restofline+  updateState (\x -> x{descriptionField=formatS})++amountfield = do+  string "amount-field"+  many1 spacenonewline+  v <- restofline+  x <- updateState (\r -> r{amountField=readMay v})+  return x++amountinfield = do+  choice [string "amount-in-field", string "in-field"]+  many1 spacenonewline+  v <- restofline+  updateState (\r -> r{amountInField=readMay v})++amountoutfield = do+  choice [string "amount-out-field", string "out-field"]+  many1 spacenonewline+  v <- restofline+  updateState (\r -> r{amountOutField=readMay v})++currencyfield = do+  string "currency-field"+  many1 spacenonewline+  v <- restofline+  updateState (\r -> r{currencyField=readMay v})++accountfield = do+  string "account-field"+  many1 spacenonewline+  v <- restofline+  updateState (\r -> r{accountField=readMay v})++account2field = do+  string "account2-field"+  many1 spacenonewline+  v <- restofline+  updateState (\r -> r{account2Field=readMay v})++basecurrency = do+  choice [string "base-currency", string "currency"]+  many1 spacenonewline+  v <- restofline+  updateState (\r -> r{baseCurrency=Just v})++baseaccount = do+  string "base-account"+  many1 spacenonewline+  v <- accountname+  optional newline+  updateState (\r -> r{baseAccount=v})++accountrule :: GenParser Char CsvRules AccountRule+accountrule = do+  many blankorcommentline+  pats <- many1 matchreplacepattern+  guard $ length pats >= 2+  let pats' = init pats+      acct = either (fail.show) id $ runParser accountname () "" $ fst $ last pats+  many blankorcommentline+  return (pats',acct)+ <?> "account rule"++blankline = many spacenonewline >> newline >> return () <?> "blank line"++commentchar = oneOf ";#"++commentline = many spacenonewline >> commentchar >> restofline >> return () <?> "comment line"++blankorcommentline = choice' [blankline, commentline]++matchreplacepattern = do+  notFollowedBy commentchar+  matchpat <- many1 (noneOf "=\n")+  replpat <- optionMaybe $ do {char '='; many $ noneOf "\n"}+  newline+  return (matchpat,replpat)++validateRules :: CsvRules -> Either String CsvRules+validateRules rules =+ let hasAmount = isJust $ amountField rules+     hasIn = isJust $ amountInField rules+     hasOut = isJust $ amountOutField rules+ in case (hasAmount, hasIn, hasOut) of+    (True, True, _) -> Left "Don't specify amount-in-field when specifying amount-field"+    (True, _, True) -> Left "Don't specify amount-out-field when specifying amount-field"+    (_, False, True) -> Left "Please specify amount-in-field when specifying amount-out-field"+    (_, True, False) -> Left "Please specify amount-out-field when specifying amount-in-field"+    (False, False, False) -> Left "Please specify either amount-field, or amount-in-field and amount-out-field"+    _ -> Right rules++-- csv record conversion+formatD :: CsvRecord -> Bool -> Maybe Int -> Maybe Int -> HledgerFormatField -> String+formatD record leftJustified min max f = case f of +  FieldNo n       -> maybe "" show $ atMay record n+  -- Some of these might in theory in read from fields+  AccountField         -> ""+  DepthSpacerField     -> ""+  TotalField           -> ""+  DefaultDateField     -> ""+  DescriptionField     -> ""+ where+   show = formatValue leftJustified min max++formatDescription :: CsvRecord -> [FormatString] -> String+formatDescription _ [] = ""+formatDescription record (f:fs) = s ++ (formatDescription record fs)+  where s = case f of+                FormatLiteral l -> l+                FormatField leftJustified min max field  -> formatD record leftJustified min max field++transactionFromCsvRecord :: CsvRules -> CsvRecord -> Transaction+transactionFromCsvRecord rules fields =+  let +      date = parsedate $ normaliseDate (dateFormat rules) $ maybe "1900/1/1" (atDef "" fields) (dateField rules)+      effectivedate = do idx <- effectiveDateField rules+                         return $ parsedate $ normaliseDate (dateFormat rules) $ (atDef "" fields) idx+      status = maybe False (null . strip . (atDef "" fields)) (statusField rules)+      code = maybe "" (atDef "" fields) (codeField rules)+      desc = formatDescription fields (descriptionField rules)+      comment = ""+      precomment = ""+      baseacc = maybe (baseAccount rules) (atDef "" fields) (accountField rules)+      amountstr = getAmount rules fields+      amountstr' = strnegate amountstr where strnegate ('-':s) = s+                                             strnegate s = '-':s+      currency = maybe (fromMaybe "" $ baseCurrency rules) (atDef "" fields) (currencyField rules)+      amountstr'' = currency ++ amountstr'+      amountparse = runParser amount nullctx "" amountstr''+      a = either (const nullmixedamt) id amountparse+      -- Using costOfMixedAmount here to allow complex costs like "10 GBP @@ 15 USD".+      -- Aim is to have "10 GBP @@ 15 USD" applied to account "acct", but have "-15USD" applied to "baseacct"+      baseamount = costOfMixedAmount a+      unknownacct | (readDef 0 amountstr' :: Double) < 0 = "income:unknown"+                  | otherwise = "expenses:unknown"+      (acct',newdesc) = identify (accountRules rules) unknownacct desc+      acct = maybe acct' (atDef "" fields) (account2Field rules)+      t = Transaction {+              tdate=date,+              teffectivedate=effectivedate,+              tstatus=status,+              tcode=code,+              tdescription=newdesc,+              tcomment=comment,+              tpreceding_comment_lines=precomment,+              ttags=[],+              tpostings=[+                   Posting {+                     pstatus=False,+                     paccount=acct,+                     pamount=a,+                     pcomment="",+                     ptype=RegularPosting,+                     ptags=[],+                     ptransaction=Just t+                   },+                   Posting {+                     pstatus=False,+                     paccount=baseacc,+                     pamount=(-baseamount),+                     pcomment="",+                     ptype=RegularPosting,+                     ptags=[],+                     ptransaction=Just t+                   }+                  ]+            }+  in t++-- | Convert some date string with unknown format to YYYY/MM/DD.+normaliseDate :: Maybe String -- ^ User-supplied date format: this should be tried in preference to all others+              -> String -> String+normaliseDate mb_user_format s =+    let parsewith = flip (parseTime defaultTimeLocale) s in+    maybe (error' $ "could not parse \""++s++"\" as a date, consider adding a date-format directive or upgrading")+          showDate $+          firstJust $ (map parsewith $+                       maybe [] (:[]) mb_user_format+                       -- the - modifier requires time-1.2.0.5, released+                       -- in 2011/5, so for now we emulate it for wider+                       -- compatibility.  time < 1.2.0.5 also has a buggy+                       -- %y which we don't do anything about.+                       -- ++ [+                       -- "%Y/%m/%d"+                       -- ,"%Y/%-m/%-d"+                       -- ,"%Y-%m-%d"+                       -- ,"%Y-%-m-%-d"+                       -- ,"%m/%d/%Y"+                       -- ,"%-m/%-d/%Y"+                       -- ,"%m-%d-%Y"+                       -- ,"%-m-%-d-%Y"+                       -- ]+                      )+                      ++ [+                       parseTime defaultTimeLocale "%Y/%m/%e" s+                      ,parseTime defaultTimeLocale "%Y-%m-%e" s+                      ,parseTime defaultTimeLocale "%m/%e/%Y" s+                      ,parseTime defaultTimeLocale "%m-%e-%Y" s+                      ,parseTime defaultTimeLocale "%Y/%m/%e" (take 5 s ++ "0" ++ drop 5 s)+                      ,parseTime defaultTimeLocale "%Y-%m-%e" (take 5 s ++ "0" ++ drop 5 s)+                      ,parseTime defaultTimeLocale "%m/%e/%Y" ('0':s)+                      ,parseTime defaultTimeLocale "%m-%e-%Y" ('0':s)+                      ]++-- | Apply account matching rules to a transaction description to obtain+-- the most appropriate account and a new description.+identify :: [AccountRule] -> String -> String -> (String,String)+identify rules defacct desc | null matchingrules = (defacct,desc)+                            | otherwise = (acct,newdesc)+    where+      matchingrules = filter ismatch rules :: [AccountRule]+          where ismatch = any ((`regexMatchesCI` desc) . fst) . fst+      (prs,acct) = head matchingrules+      p_ms_r = filter (\(_,m,_) -> m) $ map (\(p,r) -> (p, p `regexMatchesCI` desc, r)) prs+      (p,_,r) = head p_ms_r+      newdesc = case r of Just repl -> regexReplaceCI p repl desc+                          Nothing   -> desc++getAmount :: CsvRules -> CsvRecord -> String+getAmount rules fields = case amountField rules of+  Just f  -> maybe "" (atDef "" fields) $ Just f+  Nothing ->+    case (i, o) of+      (x, "") -> x+      ("", x) -> "-"++x+      p -> error' $ "using amount-in-field and amount-out-field, found a value in both fields: "++show p+    where+      i = maybe "" (atDef "" fields) (amountInField rules)+      o = maybe "" (atDef "" fields) (amountOutField rules)++tests_Hledger_Read_CsvReader = TestList (test_parser ++ test_description_parsing)++test_description_parsing = [+      "description-field 1" ~: assertParseDescription "description-field 1\n" [FormatField False Nothing Nothing (FieldNo 1)]+    , "description-field 1 " ~: assertParseDescription "description-field 1 \n" [FormatField False Nothing Nothing (FieldNo 1)]+    , "description-field %(1)" ~: assertParseDescription "description-field %(1)\n" [FormatField False Nothing Nothing (FieldNo 1)]+    , "description-field %(1)/$(2)" ~: assertParseDescription "description-field %(1)/%(2)\n" [+          FormatField False Nothing Nothing (FieldNo 1)+        , FormatLiteral "/"+        , FormatField False Nothing Nothing (FieldNo 2)+        ]+    ]+  where+    assertParseDescription string expected = do assertParseEqual (parseDescription string) (nullrules {descriptionField = expected})+    parseDescription :: String -> Either ParseError CsvRules+    parseDescription x = runParser descriptionfieldWrapper nullrules "(unknown)" x+    descriptionfieldWrapper :: GenParser Char CsvRules CsvRules+    descriptionfieldWrapper = do+      descriptionfield+      r <- getState+      return r++test_parser =  [++   "convert rules parsing: empty file" ~: do+     -- let assertMixedAmountParse parseresult mixedamount =+     --         (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount)+    assertParseEqual (parseCsvRules "unknown" "") nullrules++  ,"convert rules parsing: accountrule" ~: do+     assertParseEqual (parseWithCtx nullrules accountrule "A\na\n") -- leading blank line required+                 ([("A",Nothing)], "a")++  ,"convert rules parsing: trailing comments" ~: do+     assertParse (parseWithCtx nullrules csvrulesfile "A\na\n# \n#\n")++  ,"convert rules parsing: trailing blank lines" ~: do+     assertParse (parseWithCtx nullrules csvrulesfile "A\na\n\n  \n")++  -- not supported+  -- ,"convert rules parsing: no final newline" ~: do+  --    assertParse (parseWithCtx nullrules csvrulesfile "A\na")+  --    assertParse (parseWithCtx nullrules csvrulesfile "A\na\n# \n#")+  --    assertParse (parseWithCtx nullrules csvrulesfile "A\na\n\n  ")++                 -- (nullrules{+                 --   -- dateField=Maybe FieldPosition,+                 --   -- statusField=Maybe FieldPosition,+                 --   -- codeField=Maybe FieldPosition,+                 --   -- descriptionField=Maybe FieldPosition,+                 --   -- amountField=Maybe FieldPosition,+                 --   -- currencyField=Maybe FieldPosition,+                 --   -- baseCurrency=Maybe String,+                 --   -- baseAccount=AccountName,+                 --   accountRules=[+                 --        ([("A",Nothing)], "a")+                 --       ]+                 --  })++  ]

@@ -1,145 +1,63 @@+{-# LANGUAGE RecordWildCards #-} {-| -A reader for hledger's (and c++ ledger's) journal file format.--From the ledger 2.5 manual:+A reader for hledger's journal file format+(<http://hledger.org/MANUAL.html#the-journal-file>).  hledger's journal+format is a compatible subset of c++ ledger's+(<http://ledger-cli.org/3.0/doc/ledger3.html#Journal-Format>), so this+reader should handle many ledger files as well. Example:  @-The ledger file format is quite simple, but also very flexible. It supports-many options, though typically the user can ignore most of them. They are-summarized below.  The initial character of each line determines what the-line means, and how it should be interpreted. Allowable initial characters-are:--NUMBER      A line beginning with a number denotes an entry. It may be followed by any-            number of lines, each beginning with whitespace, to denote the entry’s account-            transactions. The format of the first line is:--                    DATE[=EDATE] [*|!] [(CODE)] DESC--            If ‘*’ appears after the date (with optional effective date), it indicates the entry-            is “cleared”, which can mean whatever the user wants it t omean. If ‘!’ appears-            after the date, it indicates d the entry is “pending”; i.e., tentatively cleared from-            the user’s point of view, but not yet actually cleared. If a ‘CODE’ appears in-            parentheses, it may be used to indicate a check number, or the type of the-            transaction. Following these is the payee, or a description of the transaction.-            The format of each following transaction is:--                      ACCOUNT     AMOUNT    [; NOTE]--            The ‘ACCOUNT’ may be surrounded by parentheses if it is a virtual-            transactions, or square brackets if it is a virtual transactions that must-            balance. The ‘AMOUNT’ can be followed by a per-unit transaction cost,-            by specifying ‘ AMOUNT’, or a complete transaction cost with ‘\@ AMOUNT’.-            Lastly, the ‘NOTE’ may specify an actual and/or effective date for the-            transaction by using the syntax ‘[ACTUAL_DATE]’ or ‘[=EFFECTIVE_DATE]’ or-            ‘[ACTUAL_DATE=EFFECtIVE_DATE]’.--=           An automated entry. A value expression must appear after the equal sign.-            After this initial line there should be a set of one or more transactions, just as-            if it were normal entry. If the amounts of the transactions have no commodity,-            they will be applied as modifiers to whichever real transaction is matched by-            the value expression.- -~           A period entry. A period expression must appear after the tilde.-            After this initial line there should be a set of one or more transactions, just as-            if it were normal entry.--!           A line beginning with an exclamation mark denotes a command directive. It-            must be immediately followed by the command word. The supported commands-            are:--           ‘!include’-                        Include the stated ledger file.-           ‘!account’-                        The account name is given is taken to be the parent of all transac--                        tions that follow, until ‘!end’ is seen.-           ‘!end’       Ends an account block.- -;          A line beginning with a colon indicates a comment, and is ignored.- -Y          If a line begins with a capital Y, it denotes the year used for all subsequent-           entries that give a date without a year. The year should appear immediately-           after the Y, for example: ‘Y2004’. This is useful at the beginning of a file, to-           specify the year for that file. If all entries specify a year, however, this command-           has no effect.-           - -P          Specifies a historical price for a commodity. These are usually found in a pricing-           history file (see the ‘-Q’ option). The syntax is:--                  P DATE SYMBOL PRICE--N SYMBOL   Indicates that pricing information is to be ignored for a given symbol, nor will-           quotes ever be downloaded for that symbol. Useful with a home currency, such-           as the dollar ($). It is recommended that these pricing options be set in the price-           database file, which defaults to ‘~/.pricedb’. The syntax for this command is:--                  N SYMBOL--        -D AMOUNT   Specifies the default commodity to use, by specifying an amount in the expected-           format. The entry command will use this commodity as the default when none-           other can be determined. This command may be used multiple times, to set-           the default flags for different commodities; whichever is seen last is used as the-           default commodity. For example, to set US dollars as the default commodity,-           while also setting the thousands flag and decimal flag for that commodity, use:--                  D $1,000.00--C AMOUNT1 = AMOUNT2-           Specifies a commodity conversion, where the first amount is given to be equiv--           alent to the second amount. The first amount should use the decimal precision-           desired during reporting:--                  C 1.00 Kb = 1024 bytes--i, o, b, h-           These four relate to timeclock support, which permits ledger to read timelog-           files. See the timeclock’s documentation for more info on the syntax of its-           timelog files.+2012\/3\/24 gift+    expenses:gifts  $10+    assets:cash @  -}  module Hledger.Read.JournalReader (-       emptyLine,-       journalAddFile,-       journalFile,-       ledgeraccountname,-       ledgerdatetime,-       ledgerDefaultYear,-       ledgerDirective,-       ledgerHistoricalPrice,-       reader,-       someamount,-       tests_Hledger_Read_JournalReader+  -- * Reader+  reader,+  -- * Parsers used elsewhere+  parseJournalWith,+  getParentAccount,+  journal,+  directive,+  defaultyeardirective,+  historicalpricedirective,+  datetime,+  accountname,+  amount,+  amount',+  emptyline,+  -- * Tests+  tests_Hledger_Read_JournalReader ) where+import qualified Control.Exception as C import Control.Monad import Control.Monad.Error import Data.Char (isNumber)+import Data.Either (partitionEithers) import Data.List import Data.List.Split (wordsBy) import Data.Maybe import Data.Time.Calendar--- import Data.Time.Clock--- import Data.Time.Format import Data.Time.LocalTime import Safe (headDef)--- import System.Locale (defaultTimeLocale) import Test.HUnit import Text.ParserCombinators.Parsec hiding (parse) import Text.Printf+import System.FilePath+import System.Time (getClockTime)  import Hledger.Data-import Hledger.Read.Utils import Hledger.Utils import Prelude hiding (readFile)-import Hledger.Utils.UTF8 (readFile)+import Hledger.Utils.UTF8IOCompat (readFile)  --- let's get to it+-- standard reader exports  reader :: Reader reader = Reader format detect parse@@ -149,76 +67,113 @@  -- | Does the given file path and data provide hledger's journal file format ? detect :: FilePath -> String -> Bool-detect f _ = fileSuffix f == format+detect f _ = takeExtension f `elem` ['.':format, ".j"]  -- | Parse and post-process a "Journal" from hledger's journal file -- format, or give an error.-parse :: FilePath -> String -> ErrorT String IO Journal-parse = parseJournalWith journalFile+parse :: Maybe FilePath -> FilePath -> String -> ErrorT String IO Journal+parse _ = -- trace ("running "++format++" reader") .+          parseJournalWith journal +-- parsing utils++-- | Flatten a list of JournalUpdate's into a single equivalent one.+combineJournalUpdates :: [JournalUpdate] -> JournalUpdate+combineJournalUpdates us = liftM (foldr (.) 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+  tc <- liftIO getClockTime+  tl <- liftIO getCurrentLocalTime+  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+                             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})++getYear :: GenParser tok JournalContext (Maybe Integer)+getYear = liftM ctxYear getState++setCommodity :: Commodity -> GenParser tok JournalContext ()+setCommodity c = updateState (\ctx -> ctx{ctxCommodity=Just c})++getCommodity :: GenParser tok JournalContext (Maybe Commodity)+getCommodity = liftM ctxCommodity getState++pushParentAccount :: String -> GenParser tok JournalContext ()+pushParentAccount parent = updateState addParentAccount+    where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 }++popParentAccount :: GenParser tok JournalContext ()+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 = liftM (concatAccountNames . reverse . ctxAccount) getState++addAccountAlias :: (AccountName,AccountName) -> GenParser tok JournalContext ()+addAccountAlias a = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})++getAccountAliases :: GenParser tok JournalContext [(AccountName,AccountName)]+getAccountAliases = liftM ctxAliases getState++clearAccountAliases :: GenParser tok JournalContext ()+clearAccountAliases = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})++-- 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.-journalFile :: GenParser Char JournalContext (JournalUpdate,JournalContext)-journalFile = do+journal :: GenParser Char JournalContext (JournalUpdate,JournalContext)+journal = do   journalupdates <- many journalItem   eof   finalctx <- getState-  return $ (juSequence journalupdates, finalctx)+  return $ (combineJournalUpdates journalupdates, finalctx)     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-      journalItem = choice [ ledgerDirective-                           , liftM (return . addTransaction) ledgerTransaction-                           , liftM (return . addModifierTransaction) ledgerModifierTransaction-                           , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction-                           , liftM (return . addHistoricalPrice) ledgerHistoricalPrice-                           , emptyLine >> return (return id)+      journalItem = choice [ directive+                           , liftM (return . addTransaction) transaction+                           , liftM (return . addModifierTransaction) modifiertransaction+                           , liftM (return . addPeriodicTransaction) periodictransaction+                           , liftM (return . addHistoricalPrice) historicalpricedirective+                           , emptyline >> return (return id)                            ] <?> "journal transaction or directive" -emptyLine :: GenParser Char JournalContext ()-emptyLine = do many spacenonewline-               optional $ (char ';' <?> "comment") >> many (noneOf "\n")-               newline-               return ()--ledgercomment :: GenParser Char JournalContext String-ledgercomment = do-  many1 $ char ';'-  many spacenonewline-  many (noneOf "\n")-  <?> "comment"--ledgercommentline :: GenParser Char JournalContext String-ledgercommentline = do-  many spacenonewline-  s <- ledgercomment-  optional newline-  eof-  return s-  <?> "comment"--ledgerDirective :: GenParser Char JournalContext JournalUpdate-ledgerDirective = do+-- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives+directive :: GenParser Char JournalContext JournalUpdate+directive = do   optional $ char '!'   choice' [-    ledgerInclude-   ,ledgerAlias-   ,ledgerEndAliases-   ,ledgerAccountBegin-   ,ledgerAccountEnd-   ,ledgerTagDirective-   ,ledgerEndTagDirective-   ,ledgerDefaultYear-   ,ledgerDefaultCommodity-   ,ledgerCommodityConversion-   ,ledgerIgnoredPriceCommodity+    includedirective+   ,aliasdirective+   ,endaliasesdirective+   ,accountdirective+   ,enddirective+   ,tagdirective+   ,endtagdirective+   ,defaultyeardirective+   ,defaultcommoditydirective+   ,commodityconversiondirective+   ,ignoredpricecommoditydirective    ]   <?> "directive" -ledgerInclude :: GenParser Char JournalContext JournalUpdate-ledgerInclude = do+includedirective :: GenParser Char JournalContext JournalUpdate+includedirective = do   string "include"   many1 spacenonewline   filename <- restofline@@ -227,33 +182,33 @@   return $ do filepath <- expandPath outerPos filename               txt <- readFileOrError outerPos filepath               let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"-              case runParser journalFile outerState filepath txt of-                Right (ju,_) -> juSequence [return $ journalAddFile (filepath,txt), ju] `catchError` (throwError . (inIncluded ++))+              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 =-                ErrorT $ liftM Right (readFile fp) `catch`-                  \err -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show err)+                ErrorT $ liftM Right (readFile fp) `C.catch`+                  \e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException))  journalAddFile :: (FilePath,String) -> Journal -> Journal journalAddFile f j@Journal{files=fs} = j{files=fs++[f]} -ledgerAccountBegin :: GenParser Char JournalContext JournalUpdate-ledgerAccountBegin = do+accountdirective :: GenParser Char JournalContext JournalUpdate+accountdirective = do   string "account"   many1 spacenonewline-  parent <- ledgeraccountname+  parent <- accountname   newline   pushParentAccount parent   return $ return id -ledgerAccountEnd :: GenParser Char JournalContext JournalUpdate-ledgerAccountEnd = do+enddirective :: GenParser Char JournalContext JournalUpdate+enddirective = do   string "end"   popParentAccount   return (return id) -ledgerAlias :: GenParser Char JournalContext JournalUpdate-ledgerAlias = do+aliasdirective :: GenParser Char JournalContext JournalUpdate+aliasdirective = do   string "alias"   many1 spacenonewline   orig <- many1 $ noneOf "="@@ -263,28 +218,28 @@                   ,accountNameWithoutPostingType $ strip alias)   return $ return id -ledgerEndAliases :: GenParser Char JournalContext JournalUpdate-ledgerEndAliases = do+endaliasesdirective :: GenParser Char JournalContext JournalUpdate+endaliasesdirective = do   string "end aliases"   clearAccountAliases   return (return id) -ledgerTagDirective :: GenParser Char JournalContext JournalUpdate-ledgerTagDirective = do+tagdirective :: GenParser Char JournalContext JournalUpdate+tagdirective = do   string "tag" <?> "tag directive"   many1 spacenonewline   _ <- many1 nonspace   restofline   return $ return id -ledgerEndTagDirective :: GenParser Char JournalContext JournalUpdate-ledgerEndTagDirective = do+endtagdirective :: GenParser Char JournalContext JournalUpdate+endtagdirective = do   (string "end tag" <|> string "pop") <?> "end tag or pop directive"   restofline   return $ return id -ledgerDefaultYear :: GenParser Char JournalContext JournalUpdate-ledgerDefaultYear = do+defaultyeardirective :: GenParser Char JournalContext JournalUpdate+defaultyeardirective = do   char 'Y' <?> "default year"   many spacenonewline   y <- many1 digit@@ -293,84 +248,157 @@   setYear y'   return $ return id -ledgerDefaultCommodity :: GenParser Char JournalContext JournalUpdate-ledgerDefaultCommodity = do+defaultcommoditydirective :: GenParser Char JournalContext JournalUpdate+defaultcommoditydirective = do   char 'D' <?> "default commodity"   many1 spacenonewline-  a <- someamount-  -- someamount always returns a MixedAmount containing one Amount, but let's be safe+  a <- amount+  -- amount always returns a MixedAmount containing one Amount, but let's be safe   let as = amounts a   when (not $ null as) $ setCommodity $ commodity $ head as   restofline   return $ return id -ledgerHistoricalPrice :: GenParser Char JournalContext HistoricalPrice-ledgerHistoricalPrice = do+historicalpricedirective :: GenParser Char JournalContext HistoricalPrice+historicalpricedirective = do   char 'P' <?> "historical price"   many spacenonewline-  date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate -- a time is ignored+  date <- try (do {LocalTime d _ <- datetime; return d}) <|> date -- a time is ignored   many1 spacenonewline   symbol <- commoditysymbol   many spacenonewline-  price <- someamount+  price <- amount   restofline   return $ HistoricalPrice date symbol price -ledgerIgnoredPriceCommodity :: GenParser Char JournalContext JournalUpdate-ledgerIgnoredPriceCommodity = do+ignoredpricecommoditydirective :: GenParser Char JournalContext JournalUpdate+ignoredpricecommoditydirective = do   char 'N' <?> "ignored-price commodity"   many1 spacenonewline   commoditysymbol   restofline   return $ return id -ledgerCommodityConversion :: GenParser Char JournalContext JournalUpdate-ledgerCommodityConversion = do+commodityconversiondirective :: GenParser Char JournalContext JournalUpdate+commodityconversiondirective = do   char 'C' <?> "commodity conversion"   many1 spacenonewline-  someamount+  amount   many spacenonewline   char '='   many spacenonewline-  someamount+  amount   restofline   return $ return id -ledgerModifierTransaction :: GenParser Char JournalContext ModifierTransaction-ledgerModifierTransaction = do+modifiertransaction :: GenParser Char JournalContext ModifierTransaction+modifiertransaction = do   char '=' <?> "modifier transaction"   many spacenonewline   valueexpr <- restofline-  postings <- ledgerpostings+  postings <- postings   return $ ModifierTransaction valueexpr postings -ledgerPeriodicTransaction :: GenParser Char JournalContext PeriodicTransaction-ledgerPeriodicTransaction = do+periodictransaction :: GenParser Char JournalContext PeriodicTransaction+periodictransaction = do   char '~' <?> "periodic transaction"   many spacenonewline   periodexpr <- restofline-  postings <- ledgerpostings+  postings <- postings   return $ PeriodicTransaction periodexpr postings --- | Parse a (possibly unbalanced) ledger transaction.-ledgerTransaction :: GenParser Char JournalContext Transaction-ledgerTransaction = do-  date <- ledgerdate <?> "transaction"-  edate <- optionMaybe (ledgereffectivedate date) <?> "effective date"-  status <- ledgerstatus <?> "cleared flag"-  code <- ledgercode <?> "transaction code"-  (description, comment) <--      (do {many1 spacenonewline; d <- liftM rstrip (many (noneOf ";\n")); c <- ledgercomment <|> return ""; newline; return (d, c)} <|>-       do {many spacenonewline; c <- ledgercomment <|> return ""; newline; return ("", c)}-      ) <?> "description and/or comment"-  md <- try ledgermetadata <|> return []-  postings <- ledgerpostings-  return $ txnTieKnot $ Transaction date edate status code description comment md postings ""+-- | Parse a (possibly unbalanced) transaction.+transaction :: GenParser Char JournalContext Transaction+transaction = do+  date <- date <?> "transaction"+  edate <- optionMaybe (effectivedate date) <?> "effective date"+  status <- status <?> "cleared flag"+  code <- code <?> "transaction code"+  -- now there can be whitespace followed by a description and/or comment/tag comment+  let pdescription = many (noneOf ";\n") >>= return . strip+  (description, inlinecomment, inlinetag) <-+    try (do many1 spacenonewline+            d <- pdescription+            (c, m) <- inlinecomment+            return (d,c,m))+    <|> (newline >> return ("", [], []))+  (nextlinecomments, nextlinetags) <- commentlines+  let comment = unlines $ inlinecomment ++ nextlinecomments+      tags = inlinetag ++ nextlinetags+  postings <- postings+  return $ txnTieKnot $ Transaction date edate status code description comment tags postings "" +tests_transaction = [+   "transaction" ~: do+    -- let s `gives` t = assertParseEqual (parseWithCtx nullctx transaction s) t+    let s `gives` t = do+                        let p = parseWithCtx nullctx transaction s+                        assertBool "transaction parser failed" $ isRight p+                        let Right t2 = p+                            same f = assertEqual "" (f t) (f t2)+                        same tdate+                        same teffectivedate+                        same tstatus+                        same tcode+                        same tdescription+                        same tcomment+                        same ttags+                        same tpreceding_comment_lines+                        same tpostings+    -- "0000/01/01\n\n" `gives` nulltransaction +    unlines [+      "2012/05/14=2012/05/15 (code) desc  ; tcomment1",+      "    ; tcomment2",+      "    ; ttag1: val1",+      "    * a         $1.00  ; pcomment1",+      "    ; pcomment2",+      "    ; ptag1: val1",+      "    ; ptag2: val2"+      ]+     `gives`+     nulltransaction{+      tdate=parsedate "2012/05/14",+      teffectivedate=Just $ parsedate "2012/05/15",+      tstatus=False,+      tcode="code",+      tdescription="desc",+      tcomment="tcomment1\ntcomment2\n",+      ttags=[("ttag1","val1")],+      tpostings=[+        nullposting{+          pstatus=True,+          paccount="a",+          pamount=Mixed [dollars 1],+          pcomment="pcomment1\npcomment2\n",+          ptype=RegularPosting,+          ptags=[("ptag1","val1"),("ptag2","val2")],+          ptransaction=Nothing+          }+        ],+      tpreceding_comment_lines=""+      }++    assertParseEqual (parseWithCtx nullctx transaction entry1_str) entry1+    assertBool "transaction should not parse just a date"+                   $ isLeft $ parseWithCtx nullctx transaction "2009/1/1\n"+    assertBool "transaction should require some postings"+                   $ isLeft $ parseWithCtx nullctx transaction "2009/1/1 a\n"+    let t = parseWithCtx nullctx transaction "2009/1/1 a ;comment\n b 1\n"+    assertBool "transaction should not include a comment in the description"+                   $ either (const False) ((== "a") . tdescription) t+    assertBool "parse transaction with following whitespace line" $+       isRight $ parseWithCtx nullctx transaction $ unlines [+         "2012/1/1"+        ,"  a  1"+        ,"  b"+        ," "+        ]+ ]+ -- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed. The year -- may be omitted if a default year has already been set.-ledgerdate :: GenParser Char JournalContext Day-ledgerdate = do+date :: GenParser Char JournalContext Day+date = do   -- hacky: try to ensure precise errors for invalid dates   -- XXX reported error position is not too good   -- pos <- getPosition@@ -392,9 +420,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.-ledgerdatetime :: GenParser Char JournalContext LocalTime-ledgerdatetime = do -  day <- ledgerdate+datetime :: GenParser Char JournalContext LocalTime+datetime = do+  day <- date   many1 spacenonewline   h <- many1 digit   let h' = read h@@ -420,8 +448,8 @@   -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')   return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') -ledgereffectivedate :: Day -> GenParser Char JournalContext Day-ledgereffectivedate actualdate = do+effectivedate :: Day -> GenParser Char JournalContext Day+effectivedate actualdate = do   char '='   -- kludgy way to use actual date for default year   let withDefaultYear d p = do@@ -430,81 +458,68 @@         r <- p         when (isJust y) $ setYear $ fromJust y         return r-  edate <- withDefaultYear actualdate ledgerdate+  edate <- withDefaultYear actualdate date   return edate -ledgerstatus :: GenParser Char JournalContext Bool-ledgerstatus = try (do { many spacenonewline; char '*' <?> "status"; return True } ) <|> return False--ledgercode :: GenParser Char JournalContext String-ledgercode = try (do { many1 spacenonewline; char '(' <?> "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""--ledgermetadata :: GenParser Char JournalContext [(String,String)]-ledgermetadata = many ledgermetadataline+status :: GenParser Char JournalContext Bool+status = try (do { many spacenonewline; char '*' <?> "status"; return True } ) <|> return False --- a comment line containing a metadata declaration, eg:--- ; name: value-ledgermetadataline :: GenParser Char JournalContext (String,String)-ledgermetadataline = do-  many1 spacenonewline-  many1 $ char ';'-  many spacenonewline-  name <- many1 $ noneOf ": \t"-  char ':'-  many spacenonewline-  value <- many (noneOf "\n")-  optional newline---  eof-  return (name,value)-  <?> "metadata line"+code :: GenParser Char JournalContext String+code = try (do { many1 spacenonewline; char '(' <?> "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" --- Parse the following whitespace-beginning lines as postings, posting metadata, and/or comments.--- complicated to handle intermixed comment and metadata lines.. make me better ?-ledgerpostings :: GenParser Char JournalContext [Posting]-ledgerpostings = do-  ctx <- getState-  -- we'll set the correct position for sub-parses for more useful errors-  pos <- getPosition-  ls <- many1 $ try linebeginningwithspaces-  let lsnumbered = zip ls [0..]-      parses p = isRight . parseWithCtx ctx p-      postinglines = filter (not . (ledgercommentline `parses`) . fst) lsnumbered-      -- group any metadata lines with the posting line above-      postinglinegroups :: [(String,Line)] -> [(String,Line)]-      postinglinegroups [] = []-      postinglinegroups ((pline,num):ls) = (unlines (pline:(map fst mdlines)), num):postinglinegroups rest-          where (mdlines,rest) = span ((ledgermetadataline `parses`) . fst) ls-      pstrs = postinglinegroups postinglines-      parseNumberedPostingLine (str,num) = fromparse $ parseWithCtx ctx (setPosition (incSourceLine pos num) >> ledgerposting) str-  when (null pstrs) $ fail "no postings"-  return $ map parseNumberedPostingLine pstrs-  <?> "postings"+-- Parse the following whitespace-beginning lines as postings, posting tags, and/or comments.+postings :: GenParser Char JournalContext [Posting]+postings = many1 (try posting) <?> "postings"             -linebeginningwithspaces :: GenParser Char JournalContext String-linebeginningwithspaces = do-  sp <- many1 spacenonewline-  c <- nonspace-  cs <- restofline-  return $ sp ++ (c:cs) ++ "\n"+-- linebeginningwithspaces :: GenParser Char JournalContext String+-- linebeginningwithspaces = do+--   sp <- many1 spacenonewline+--   c <- nonspace+--   cs <- restofline+--   return $ sp ++ (c:cs) ++ "\n" -ledgerposting :: GenParser Char JournalContext Posting-ledgerposting = do+posting :: GenParser Char JournalContext Posting+posting = do   many1 spacenonewline-  status <- ledgerstatus+  status <- status   many spacenonewline   account <- modifiedaccountname   let (ptype, account') = (accountNamePostingType account, unbracket account)-  amount <- postingamount+  amount <- spaceandamountormissing   many spacenonewline-  comment <- ledgercomment <|> return ""-  newline-  md <- ledgermetadata-  return (Posting status account' amount comment ptype md Nothing)+  (inlinecomment, inlinetag) <- inlinecomment+  (nextlinecomments, nextlinetags) <- commentlines+  let comment = unlines $ inlinecomment ++ nextlinecomments+      tags = inlinetag ++ nextlinetags+  return (Posting status account' amount comment ptype tags Nothing) --- Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.+tests_posting = [+  "posting" ~: do+    -- let s `gives` r = assertParseEqual (parseWithCtx nullctx posting s) r+    let s `gives` p = do+                         let parse = parseWithCtx nullctx posting s+                         assertBool "posting parser" $ isRight parse+                         let Right p2 = parse+                             same f = assertEqual "" (f p) (f p2)+                         same pstatus+                         same paccount+                         same pamount+                         same pcomment+                         same ptype+                         same ptags+                         same ptransaction+    "  expenses:food:dining  $10.00   ; a: a a \n   ; b: b b \n"+     `gives`+     (Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting [("a","a a"), ("b","b b")] Nothing)++    assertBool "posting parses a quoted commodity with numbers"+      (isRight $ parseWithCtx nullctx posting "  a  1 \"DE123\"\n")+ ]++-- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect. modifiedaccountname :: GenParser Char JournalContext AccountName modifiedaccountname = do-  a <- ledgeraccountname+  a <- accountname   prefix <- getParentAccount   let prefixed = prefix `joinAccountNames` a   aliases <- getAccountAliases@@ -514,8 +529,8 @@ -- them, and are terminated by two or more spaces. They should have one or -- more components of at least one character, separated by the account -- separator char.-ledgeraccountname :: GenParser Char st AccountName-ledgeraccountname = do+accountname :: GenParser Char st AccountName+accountname = do     a <- many1 (nonspace <|> singlespace)     let a' = striptrailingspace a     when (accountNameFromComponents (accountNameComponents a') /= a')@@ -529,18 +544,56 @@ -- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace --     <?> "account name character (non-bracket, non-parenthesis, non-whitespace)" --- | Parse an amount, with an optional left or right currency symbol and--- optional price.-postingamount :: GenParser Char JournalContext MixedAmount-postingamount =+-- | 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 =   try (do         many1 spacenonewline-        someamount <|> return missingamt-      ) <|> return missingamt+        amount <|> return missingmixedamt+      ) <|> return missingmixedamt -someamount :: GenParser Char JournalContext MixedAmount-someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount +tests_spaceandamountormissing = [+   "spaceandamountormissing" ~: do+    assertParseEqual (parseWithCtx nullctx spaceandamountormissing " $47.18") (Mixed [dollars 47.18])+    assertParseEqual (parseWithCtx nullctx spaceandamountormissing "$47.18") missingmixedamt+    assertParseEqual (parseWithCtx nullctx spaceandamountormissing " ") missingmixedamt+    assertParseEqual (parseWithCtx nullctx spaceandamountormissing "") missingmixedamt+ ] +-- | Parse an amount, with an optional left or right currency symbol and+-- optional price.+amount :: GenParser Char JournalContext MixedAmount+amount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount++tests_amount = [+   "amount" ~: do+    assertParseEqual (parseWithCtx nullctx amount "$47.18") (Mixed [dollars 47.18])+    assertParseEqual (parseWithCtx nullctx amount "$1.")+                (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} 1 Nothing])+  ,"amount with unit price" ~: do+    assertParseEqual+     (parseWithCtx nullctx amount "$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}])}])+  ,"amount with total price" ~: do+    assertParseEqual+     (parseWithCtx nullctx amount "$10 @@ €5")+     (Mixed [Amount{commodity=dollar{precision=0},+                    quantity=10,+                    price=(Just $ TotalPrice $ Mixed [Amount{commodity=euro{precision=0},+                                                             quantity=5,+                                                             price=Nothing}])}])+ ]++-- | Run the amount parser on a string to get the result or an error.+amount' :: String -> MixedAmount+amount' s = either (error' . show) id $ parseWithCtx nullctx amount s+ leftsymbolamount :: GenParser Char JournalContext MixedAmount leftsymbolamount = do   sign <- optionMaybe $ string "-"@@ -593,56 +646,14 @@           try (do                 char '@'                 many spacenonewline-                a <- someamount -- XXX can parse more prices ad infinitum, shouldn't+                a <- amount -- 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+            a <- amount -- XXX can parse more prices ad infinitum, shouldn't             return $ Just $ UnitPrice a))          <|> return Nothing --- gawd.. trying to parse a ledger number without error:--type Quantity = Double---- -- | 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"---- -- | 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)- -- | 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@@ -692,8 +703,7 @@   return (quantity,precision,decimalpoint,separator,separatorpositions)   <?> "number" -tests_Hledger_Read_JournalReader = TestList [-+tests_number = [     "number" ~: do       let s `is` n = assertParseEqual (parseWithCtx nullctx number s) n           assertFails = assertBool "" . isLeft . parseWithCtx nullctx number @@ -715,40 +725,121 @@       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"-    assertBool "ledgerTransaction should require some postings"-                   $ isLeft $ parseWithCtx nullctx ledgerTransaction "2009/1/1 a\n"-    let t = parseWithCtx nullctx ledgerTransaction "2009/1/1 a ;comment\n b 1\n"-    assertBool "ledgerTransaction should not include a comment in the description"-                   $ either (const False) ((== "a") . tdescription) t+-- older comment parsers -  ,"ledgerModifierTransaction" ~: do-     assertParse (parseWithCtx nullctx ledgerModifierTransaction "= (some value expr)\n some:postings  1\n")+emptyline :: GenParser Char JournalContext ()+emptyline = do many spacenonewline+               optional $ (char ';' <?> "comment") >> many (noneOf "\n")+               newline+               return () -  ,"ledgerPeriodicTransaction" ~: do-     assertParse (parseWithCtx nullctx ledgerPeriodicTransaction "~ (some period expr)\n some:postings  1\n")+comment :: GenParser Char JournalContext String+comment = do+  many1 $ char ';'+  many spacenonewline+  c <- many (noneOf "\n")+  return $ rstrip c+  <?> "comment" -  ,"ledgerDirective" ~: do-     assertParse (parseWithCtx nullctx ledgerDirective "!include /some/file.x\n")-     assertParse (parseWithCtx nullctx ledgerDirective "account some:account\n")-     assertParse (parseWithCtx nullctx (ledgerDirective >> ledgerDirective) "!account a\nend\n")+commentline :: GenParser Char JournalContext String+commentline = do+  many spacenonewline+  c <- comment+  optional newline+  eof+  return c+  <?> "comment" -  ,"ledgercommentline" ~: do-     assertParse (parseWithCtx nullctx ledgercommentline "; some comment \n")-     assertParse (parseWithCtx nullctx ledgercommentline " \t; x\n")-     assertParse (parseWithCtx nullctx ledgercommentline ";x")+-- newer comment parsers -  ,"ledgerdate" ~: do-     assertParse (parseWithCtx nullctx ledgerdate "2011/1/1")-     assertParseFailure (parseWithCtx nullctx ledgerdate "1/1")-     assertParse (parseWithCtx nullctx{ctxYear=Just 2011} ledgerdate "1/1")+inlinecomment :: GenParser Char JournalContext ([String],[Tag])+inlinecomment = try (do {tag <- tagcomment; newline; return ([], [tag])})+                    <|> (do {c <- comment; newline; return ([rstrip c], [])})+                    <|> (newline >> return ([], [])) -  ,"ledgerdatetime" ~: do-      let p = do {t <- ledgerdatetime; eof; return t}+tests_inlinecomment = [+   "inlinecomment" ~: do+    let s `gives` r = assertParseEqual (parseWithCtx nullctx inlinecomment s) r+    ";  comment \n" `gives` (["comment"],[])+    ";tag: a value \n" `gives` ([],[("tag","a value")])+ ]++commentlines :: GenParser Char JournalContext ([String],[Tag])+commentlines = do+  comortags <- many $ choice' [(liftM Right tagline)+                             ,(do {many1 spacenonewline; c <- comment; newline; return $ Left c }) -- XXX fix commentnewline+                             ]+  return $ partitionEithers comortags++tests_commentlines = [+   "commentlines" ~: do+    let s `gives` r = assertParseEqual (parseWithCtx nullctx commentlines s) r+    "    ;  comment 1 \n ; tag1:  val1 \n ;comment 2\n;unindented comment\n"+     `gives` (["comment 1","comment 2"],[("tag1","val1")])+ ]++-- a comment line containing a tag declaration, eg:+-- ; name: value+tagline :: GenParser Char JournalContext Tag+tagline = do+  many1 spacenonewline+  tag <- tagcomment+  newline+  return tag++-- a comment containing a tag, like  "; name: some value"+tagcomment :: GenParser Char JournalContext Tag+tagcomment = do+  many1 $ char ';'+  many spacenonewline+  name <- many1 $ noneOf ": \t"+  char ':'+  many spacenonewline+  value <- many (noneOf "\n")+  return (name, rstrip value)+  <?> "tag comment"++tests_tagcomment = [+   "tagcomment" ~: do+    let s `gives` r = assertParseEqual (parseWithCtx nullctx tagcomment s) r+    ";tag: a value \n" `gives` ("tag","a value")+ ]++tests_Hledger_Read_JournalReader = TestList $ concat [+    tests_number,+    tests_amount,+    tests_spaceandamountormissing,+    tests_tagcomment,+    tests_inlinecomment,+    tests_commentlines,+    tests_posting,+    tests_transaction,+    [+   "modifiertransaction" ~: do+     assertParse (parseWithCtx nullctx modifiertransaction "= (some value expr)\n some:postings  1\n")++  ,"periodictransaction" ~: do+     assertParse (parseWithCtx nullctx periodictransaction "~ (some period expr)\n some:postings  1\n")++  ,"directive" ~: do+     assertParse (parseWithCtx nullctx directive "!include /some/file.x\n")+     assertParse (parseWithCtx nullctx directive "account some:account\n")+     assertParse (parseWithCtx nullctx (directive >> directive) "!account a\nend\n")++  ,"commentline" ~: do+     assertParse (parseWithCtx nullctx commentline "; some comment \n")+     assertParse (parseWithCtx nullctx commentline " \t; x\n")+     assertParse (parseWithCtx nullctx commentline ";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")++  ,"datetime" ~: do+      let p = do {t <- datetime; eof; return t}           bad = assertParseFailure . parseWithCtx nullctx p           good = assertParse . parseWithCtx nullctx p       bad "2011/1/1"@@ -763,69 +854,34 @@       assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00-0800") startofday       assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00+1234") startofday -  ,"ledgerDefaultYear" ~: do-     assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 2010\n")-     assertParse (parseWithCtx nullctx ledgerDefaultYear "Y 10001\n")--  ,"ledgerHistoricalPrice" ~:-    assertParseEqual (parseWithCtx nullctx ledgerHistoricalPrice "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55])--  ,"ledgerIgnoredPriceCommodity" ~: do-     assertParse (parseWithCtx nullctx ledgerIgnoredPriceCommodity "N $\n")--  ,"ledgerDefaultCommodity" ~: do-     assertParse (parseWithCtx nullctx ledgerDefaultCommodity "D $1,000.0\n")+  ,"defaultyeardirective" ~: do+     assertParse (parseWithCtx nullctx defaultyeardirective "Y 2010\n")+     assertParse (parseWithCtx nullctx defaultyeardirective "Y 10001\n") -  ,"ledgerCommodityConversion" ~: do-     assertParse (parseWithCtx nullctx ledgerCommodityConversion "C 1h = $50.00\n")+  ,"historicalpricedirective" ~:+    assertParseEqual (parseWithCtx nullctx historicalpricedirective "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55]) -  ,"ledgerTagDirective" ~: do-     assertParse (parseWithCtx nullctx ledgerTagDirective "tag foo \n")+  ,"ignoredpricecommoditydirective" ~: do+     assertParse (parseWithCtx nullctx ignoredpricecommoditydirective "N $\n") -  ,"ledgerEndTagDirective" ~: do-     assertParse (parseWithCtx nullctx ledgerEndTagDirective "end tag \n")-  ,"ledgerEndTagDirective" ~: do-     assertParse (parseWithCtx nullctx ledgerEndTagDirective "pop \n")+  ,"defaultcommoditydirective" ~: do+     assertParse (parseWithCtx nullctx defaultcommoditydirective "D $1,000.0\n") -  ,"ledgeraccountname" ~: do-    assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c")-    assertBool "ledgeraccountname rejects an empty inner component" (isLeft $ parsewith ledgeraccountname "a::c")-    assertBool "ledgeraccountname rejects an empty leading component" (isLeft $ parsewith ledgeraccountname ":b:c")-    assertBool "ledgeraccountname rejects an empty trailing component" (isLeft $ parsewith ledgeraccountname "a:b:")+  ,"commodityconversiondirective" ~: do+     assertParse (parseWithCtx nullctx commodityconversiondirective "C 1h = $50.00\n") - ,"ledgerposting" ~: do-    assertParseEqual (parseWithCtx nullctx ledgerposting "  expenses:food:dining  $10.00\n")-                     (Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting [] Nothing)-    assertBool "ledgerposting parses a quoted commodity with numbers"-                   (isRight $ parseWithCtx nullctx ledgerposting "  a  1 \"DE123\"\n")+  ,"tagdirective" ~: do+     assertParse (parseWithCtx nullctx tagdirective "tag foo \n") -  ,"someamount" ~: do-     let -- | compare a parse result with a MixedAmount, showing the debug representation for clarity-         assertMixedAmountParse parseresult mixedamount =-             (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount)-     assertMixedAmountParse (parseWithCtx nullctx someamount "1 @ $2")-                            (Mixed [Amount unknown 1 (Just $ UnitPrice $ Mixed [Amount dollar{precision=0} 2 Nothing])])+  ,"endtagdirective" ~: do+     assertParse (parseWithCtx nullctx endtagdirective "end tag \n")+     assertParse (parseWithCtx nullctx endtagdirective "pop \n") -  ,"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,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}])}])+  ,"accountname" ~: do+    assertBool "accountname parses a normal accountname" (isRight $ parsewith accountname "a:b:c")+    assertBool "accountname rejects an empty inner component" (isLeft $ parsewith accountname "a::c")+    assertBool "accountname rejects an empty leading component" (isLeft $ parsewith accountname ":b:c")+    assertBool "accountname rejects an empty trailing component" (isLeft $ parsewith accountname "a:b:")    ,"leftsymbolamount" ~: do     assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1")@@ -835,7 +891,14 @@     assertParseEqual (parseWithCtx nullctx leftsymbolamount "-$1")                      (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,decimalpoint='.',precision=0,separator=',',separatorpositions=[]} (-1) Nothing]) - ]+  ,"amount" ~: do+     let -- | compare a parse result with a MixedAmount, showing the debug representation for clarity+         assertMixedAmountParse parseresult mixedamount =+             (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount)+     assertMixedAmountParse (parseWithCtx nullctx amount "1 @ $2")+                            (Mixed [Amount unknown 1 (Just $ UnitPrice $ Mixed [Amount dollar{precision=0} 2 Nothing])])++ ]]  entry1_str = unlines  ["2007/01/28 coopportunity"

@@ -1,7 +1,13 @@ {-| -A reader for the timelog file format generated by timeclock.el.+A reader for the timelog file format generated by timeclock.el+(<http://www.emacswiki.org/emacs/TimeClock>). Example: +@+i 2007\/03\/10 12:26:00 hledger+o 2007\/03\/10 17:26:02+@+ From timeclock.el 2.6:  @@@ -32,29 +38,27 @@      now finished.  Useful for creating summary reports. @ -Example:--@-i 2007/03/10 12:26:00 hledger-o 2007/03/10 17:26:02-@- -}  module Hledger.Read.TimelogReader (-       reader,-       tests_Hledger_Read_TimelogReader+  -- * Reader+  reader,+  -- * Tests+  tests_Hledger_Read_TimelogReader ) where import Control.Monad import Control.Monad.Error import Test.HUnit import Text.ParserCombinators.Parsec hiding (parse)+import System.FilePath  import Hledger.Data-import Hledger.Read.Utils-import Hledger.Read.JournalReader (ledgerDirective, ledgerHistoricalPrice,-                                   ledgerDefaultYear, emptyLine, ledgerdatetime)+-- XXX too much reuse ?+import Hledger.Read.JournalReader (+  directive, historicalpricedirective, defaultyeardirective, emptyline, datetime,+  parseJournalWith, getParentAccount+  ) import Hledger.Utils  @@ -66,13 +70,14 @@  -- | Does the given file path and data provide timeclock.el's timelog format ? detect :: FilePath -> String -> Bool-detect f _ = fileSuffix f == format+detect f _ = takeExtension f == '.':format  -- | 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 :: FilePath -> String -> ErrorT String IO Journal-parse = parseJournalWith timelogFile+parse :: Maybe FilePath -> FilePath -> String -> ErrorT String IO Journal+parse _ = -- trace ("running "++format++" reader") .+          parseJournalWith timelogFile  timelogFile :: GenParser Char JournalContext (JournalUpdate,JournalContext) timelogFile = do items <- many timelogItem@@ -83,10 +88,10 @@       -- As all ledger line types can be distinguished by the first       -- character, excepting transactions versus empty (blank or       -- comment-only) lines, can use choice w/o try-      timelogItem = choice [ ledgerDirective-                          , liftM (return . addHistoricalPrice) ledgerHistoricalPrice-                          , ledgerDefaultYear-                          , emptyLine >> return (return id)+      timelogItem = choice [ directive+                          , liftM (return . addHistoricalPrice) historicalpricedirective+                          , defaultyeardirective+                          , emptyline >> return (return id)                           , liftM (return . addTimeLogEntry)  timelogentry                           ] <?> "timelog entry, or default year or historical price directive" @@ -95,7 +100,7 @@ timelogentry = do   code <- oneOf "bhioO"   many1 spacenonewline-  datetime <- ledgerdatetime+  datetime <- datetime   comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline)   return $ TimeLogEntry (read [code]) datetime (maybe "" rstrip comment) 

@@ -1,86 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-|-Utilities common to hledger journal readers.--}--module Hledger.Read.Utils-where--import Control.Monad.Error-import Data.List-import System.Directory (getHomeDirectory)-import System.FilePath(takeDirectory,combine)-import System.Time (getClockTime)-import Text.ParserCombinators.Parsec--import Hledger.Data.Types-import Hledger.Utils-import Hledger.Data.Posting-import Hledger.Data.Dates (getCurrentYear)-import Hledger.Data.Journal---juSequence :: [JournalUpdate] -> JournalUpdate-juSequence us = liftM (foldr (.) 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-  tc <- liftIO getClockTime-  tl <- liftIO getCurrentLocalTime-  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-                             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})--getYear :: GenParser tok JournalContext (Maybe Integer)-getYear = liftM ctxYear getState--setCommodity :: Commodity -> GenParser tok JournalContext ()-setCommodity c = updateState (\ctx -> ctx{ctxCommodity=Just c})--getCommodity :: GenParser tok JournalContext (Maybe Commodity)-getCommodity = liftM ctxCommodity getState--pushParentAccount :: String -> GenParser tok JournalContext ()-pushParentAccount parent = updateState addParentAccount-    where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 }--popParentAccount :: GenParser tok JournalContext ()-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 = liftM (concatAccountNames . reverse . ctxAccount) getState--addAccountAlias :: (AccountName,AccountName) -> GenParser tok JournalContext ()-addAccountAlias a = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})--getAccountAliases :: GenParser tok JournalContext [(AccountName,AccountName)]-getAccountAliases = liftM ctxAliases getState--clearAccountAliases :: GenParser tok JournalContext ()-clearAccountAliases = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})---- | Convert a possibly relative, possibly tilde-containing file path to an absolute one.--- using the current directory from a parsec source position. ~username is not supported.-expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath-expandPath pos fp = liftM mkAbsolute (expandHome fp)-  where-    mkAbsolute = combine (takeDirectory (sourceName pos))-    expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory-                                                      return $ homedir ++ drop 1 inname-                      | otherwise                = return inname--fileSuffix :: FilePath -> String-fileSuffix = reverse . takeWhile (/='.') . reverse . dropWhile (/='.')

@@ -20,7 +20,8 @@   whichDateFromOpts,   journalSelectingDateFromOpts,   journalSelectingAmountFromOpts,-  optsToFilterSpec,+  queryFromOpts,+  queryOptsFromOpts,   -- * Entries report   EntriesReport,   EntriesReportItem,@@ -41,7 +42,6 @@   AccountsReport,   AccountsReportItem,   accountsReport,-  accountsReport2,   isInteresting,   -- * Tests   tests_Hledger_Reports@@ -53,17 +53,22 @@ import Data.Maybe import Data.Ord import Data.Time.Calendar-import Data.Tree+-- import Data.Tree import Safe (headMay, lastMay) import System.Console.CmdArgs  -- for defaults support+import System.Time (ClockTime(TOD)) import Test.HUnit import Text.ParserCombinators.Parsec import Text.Printf  import Hledger.Data+import Hledger.Read (amount')+import Hledger.Query import Hledger.Utils --- report options, used in hledger-lib and above+-- | 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. data ReportOpts = ReportOpts {      begin_          :: Maybe Day     ,end_            :: Maybe Day@@ -77,16 +82,16 @@     ,empty_          :: Bool     ,no_elide_       :: Bool     ,real_           :: Bool-    ,flat_           :: Bool -- balance-    ,drop_           :: Int  -- balance-    ,no_total_       :: Bool -- balance+    ,flat_           :: Bool -- for balance command+    ,drop_           :: Int  -- "+    ,no_total_       :: Bool -- "     ,daily_          :: Bool     ,weekly_         :: Bool     ,monthly_        :: Bool     ,quarterly_      :: Bool     ,yearly_         :: Bool     ,format_         :: Maybe FormatStr-    ,patterns_       :: [String]+    ,query_          :: String -- all arguments, as a string  } deriving (Show)  type DisplayExp = String@@ -166,31 +171,49 @@     | cost_ opts = journalConvertAmountsToCost     | otherwise = id --- | Convert application options to the library's generic filter specification.-optsToFilterSpec :: ReportOpts -> Day -> FilterSpec-optsToFilterSpec opts@ReportOpts{..} d = FilterSpec {-                                datespan=dateSpanFromOpts d opts-                               ,cleared= clearedValueFromOpts opts-                               ,real=real_-                               ,empty=empty_-                               ,acctpats=apats-                               ,descpats=dpats-                               ,depth = depth_-                               }-    where (apats,dpats) = parsePatternArgs patterns_+-- | Convert report options and arguments to a query.+queryFromOpts :: Day -> ReportOpts -> Query+queryFromOpts d opts@ReportOpts{..} = simplifyQuery $ And $ [flagsq, argsq]+  where+    flagsq = And $+              [Date $ dateSpanFromOpts d opts]+              ++ (if real_ then [Real True] else [])+              ++ (if empty_ then [Empty True] else []) -- ?+              ++ (maybe [] ((:[]) . Status) (clearedValueFromOpts opts))+              ++ (maybe [] ((:[]) . Depth) depth_)+    argsq = fst $ parseQuery d query_ --- | Gather filter pattern arguments into a list of account patterns and a--- list of description patterns. We interpret pattern arguments as--- follows: those prefixed with "desc:" are description patterns, all--- others are account patterns; also patterns prefixed with "not:" are--- negated. not: should come after desc: if both are used.-parsePatternArgs :: [String] -> ([String],[String])-parsePatternArgs args = (as, ds')-    where-      descprefix = "desc:"-      (ds, as) = partition (descprefix `isPrefixOf`) args-      ds' = map (drop (length descprefix)) ds+tests_queryFromOpts = [+ "queryFromOpts" ~: do+  assertEqual "" Any (queryFromOpts nulldate defreportopts)+  assertEqual "" (Acct "a") (queryFromOpts nulldate defreportopts{query_="a"})+  assertEqual "" (Desc "a a") (queryFromOpts nulldate defreportopts{query_="desc:'a a'"})+  assertEqual "" (Date $ mkdatespan "2012/01/01" "2013/01/01")+                 (queryFromOpts nulldate defreportopts{begin_=Just (parsedate "2012/01/01")+                                                      ,query_="date:'to 2013'"+                                                      })+  assertEqual "" (EDate $ mkdatespan "2012/01/01" "2013/01/01")+                 (queryFromOpts nulldate defreportopts{query_="edate:'in 2012'"})+  assertEqual "" (Or [Acct "a a", Acct "'b"])+                 (queryFromOpts nulldate defreportopts{query_="'a a' 'b"})+ ] +-- | Convert report options and arguments to query options.+queryOptsFromOpts :: Day -> ReportOpts -> [QueryOpt]+queryOptsFromOpts d ReportOpts{..} = flagsqopts ++ argsqopts+  where+    flagsqopts = []+    argsqopts = snd $ parseQuery d query_++tests_queryOptsFromOpts = [+ "queryOptsFromOpts" ~: do+  assertEqual "" [] (queryOptsFromOpts nulldate defreportopts)+  assertEqual "" [] (queryOptsFromOpts nulldate defreportopts{query_="a"})+  assertEqual "" [] (queryOptsFromOpts nulldate defreportopts{begin_=Just (parsedate "2012/01/01")+                                                             ,query_="date:'to 2013'"+                                                             })+ ]+ -------------------------------------------------------------------------------  -- | A journal entries report is a list of whole transactions as@@ -200,12 +223,20 @@ type EntriesReportItem = Transaction  -- | Select transactions for an entries report.-entriesReport :: ReportOpts -> FilterSpec -> Journal -> EntriesReport-entriesReport opts fspec j = sortBy (comparing f) $ jtxns $ filterJournalTransactions fspec j'+entriesReport :: ReportOpts -> Query -> Journal -> EntriesReport+entriesReport opts q j =+  sortBy (comparing date) $ filter (q `matchesTransaction`) ts     where-      f = transactionDateFn opts-      j' = journalSelectingAmountFromOpts opts j+      date = transactionDateFn opts+      ts = jtxns $ journalSelectingAmountFromOpts opts j +tests_entriesReport = [+  "entriesReport" ~: do+    assertEqual "not acct" 1 (length $ entriesReport defreportopts (Not $ Acct "bank") samplejournal)+    let span = mkdatespan "2008/06/01" "2008/07/01"+    assertEqual "date" 3 (length $ entriesReport defreportopts (Date $ span) samplejournal)+ ]+ -------------------------------------------------------------------------------  -- | A postings report is a list of postings with a running total, a label@@ -214,32 +245,37 @@                       ,[PostingsReportItem] -- line items, one per posting                       ) type PostingsReportItem = (Maybe (Day, String) -- transaction date and description if this is the first posting-                                 ,Posting      -- the posting-                                 ,MixedAmount  -- the running total after this posting-                                 )+                          ,Posting             -- the posting, possibly with account name depth-clipped+                          ,MixedAmount         -- the running total after this posting+                          )  -- | Select postings from the journal and add running balance and other -- information to make a postings report. Used by eg hledger's register command.-postingsReport :: ReportOpts -> FilterSpec -> Journal -> PostingsReport-postingsReport opts fspec j = (totallabel, postingsReportItems ps nullposting startbal (+))+postingsReport :: ReportOpts -> Query -> Journal -> PostingsReport+postingsReport opts q j = (totallabel, postingsReportItems ps nullposting depth startbal (+))     where       ps | interval == NoInterval = displayableps          | otherwise              = summarisePostingsByInterval interval depth empty reportspan displayableps-      j' =                                journalSelectingDateFromOpts opts-                                        $ journalSelectingAmountFromOpts opts-                                        j-      (precedingps, displayableps, _) =   postingsMatchingDisplayExpr (display_ opts)-                                        $ depthClipPostings depth-                                        $ journalPostings-                                        $ filterJournalPostings fspec{depth=Nothing}-                                        j'-      (interval, depth, empty, displayexpr) = (intervalFromOpts opts, depth_ opts, empty_ opts, display_ opts)+      j' = journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j+      -- don't do depth filtering until the end+      (depth, q') = (queryDepth q, filterQuery (not . queryIsDepth) q)+      (precedingps, displayableps, _) =   dbg "ps3" $ postingsMatchingDisplayExpr (display_ opts)+                                        $ dbg "ps2" $ filter (q' `matchesPosting`)+                                        $ dbg "ps1" $ journalPostings j'+      dbg :: Show a => String -> a -> a+      -- dbg = ltrace+      dbg = flip const++      empty = queryEmpty q+      displayexpr = display_ opts  -- XXX+      interval = intervalFromOpts opts -- XXX       journalspan = journalDateSpan j'       -- requestedspan should be the intersection of any span specified       -- with period options and any span specified with display option.       -- The latter is not easily available, fake it for now.       requestedspan = periodspan `spanIntersect` displayspan-      periodspan = datespan fspec+      periodspan = queryDateSpan effectivedate q+      effectivedate = whichDateFromOpts opts == EffectiveDate       displayspan = postingsDateSpan ps           where (_,ps,_) = postingsMatchingDisplayExpr displayexpr $ journalPostings j'       matchedspan = postingsDateSpan displayableps@@ -247,21 +283,185 @@                  | otherwise = requestedspan `spanIntersect` matchedspan       startbal = sumPostings precedingps +tests_postingsReport = [+  "postingsReport" ~: do+   let (query, journal) `gives` n = (length $ snd $ postingsReport defreportopts query journal) `is` n+   (Any, nulljournal) `gives` 0+   (Any, samplejournal) `gives` 11+   -- register --depth just clips account names+   (Depth 2, samplejournal) `gives` 11+   -- (Depth 2, samplejournal) `gives` 6+   -- (Depth 1, samplejournal) `gives` 4++   assertEqual "" 11 (length $ snd $ postingsReport defreportopts Any samplejournal)+   assertEqual ""  9 (length $ snd $ postingsReport defreportopts{monthly_=True} Any samplejournal)+   assertEqual "" 19 (length $ snd $ postingsReport defreportopts{monthly_=True} (Empty True) samplejournal)+   assertEqual ""  4 (length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal)++   -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0+   -- [(Just (parsedate "2008-01-01","income"),assets:bank:checking             $1,$1)+   -- ,(Nothing,income:salary                   $-1,0)+   -- ,(Just (2008-06-01,"gift"),assets:bank:checking             $1,$1)+   -- ,(Nothing,income:gifts                    $-1,0)+   -- ,(Just (2008-06-02,"save"),assets:bank:saving               $1,$1)+   -- ,(Nothing,assets:bank:checking            $-1,0)+   -- ,(Just (2008-06-03,"eat & shop"),expenses:food                    $1,$1)+   -- ,(Nothing,expenses:supplies                $1,$2)+   -- ,(Nothing,assets:cash                     $-2,0)+   -- ,(Just (2008-12-31,"pay off"),liabilities:debts                $1,$1)+   -- ,(Nothing,assets:bank:checking            $-1,0)+   -- ]++{-+    let opts = defreportopts+    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+     ["2008/01/01 income               assets:bank:checking             $1           $1"+     ,"                                income:salary                   $-1            0"+     ,"2008/06/01 gift                 assets:bank:checking             $1           $1"+     ,"                                income:gifts                    $-1            0"+     ,"2008/06/02 save                 assets:bank:saving               $1           $1"+     ,"                                assets:bank:checking            $-1            0"+     ,"2008/06/03 eat & shop           expenses:food                    $1           $1"+     ,"                                expenses:supplies                $1           $2"+     ,"                                assets:cash                     $-2            0"+     ,"2008/12/31 pay off              liabilities:debts                $1           $1"+     ,"                                assets:bank:checking            $-1            0"+     ]++  ,"postings report with cleared option" ~:+   do +    let opts = defreportopts{cleared_=True}+    j <- readJournal' sample_journal_str+    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+     ["2008/06/03 eat & shop           expenses:food                    $1           $1"+     ,"                                expenses:supplies                $1           $2"+     ,"                                assets:cash                     $-2            0"+     ,"2008/12/31 pay off              liabilities:debts                $1           $1"+     ,"                                assets:bank:checking            $-1            0"+     ]++  ,"postings report with uncleared option" ~:+   do +    let opts = defreportopts{uncleared_=True}+    j <- readJournal' sample_journal_str+    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+     ["2008/01/01 income               assets:bank:checking             $1           $1"+     ,"                                income:salary                   $-1            0"+     ,"2008/06/01 gift                 assets:bank:checking             $1           $1"+     ,"                                income:gifts                    $-1            0"+     ,"2008/06/02 save                 assets:bank:saving               $1           $1"+     ,"                                assets:bank:checking            $-1            0"+     ]++  ,"postings report sorts by date" ~:+   do +    j <- readJournal' $ unlines+        ["2008/02/02 a"+        ,"  b  1"+        ,"  c"+        ,""+        ,"2008/01/01 d"+        ,"  e  1"+        ,"  f"+        ]+    let opts = defreportopts+    registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/02/02"]++  ,"postings report with account pattern" ~:+   do+    j <- samplejournal+    let opts = defreportopts{patterns_=["cash"]}+    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+     ["2008/06/03 eat & shop           assets:cash                     $-2          $-2"+     ]++  ,"postings report with account pattern, case insensitive" ~:+   do +    j <- samplejournal+    let opts = defreportopts{patterns_=["cAsH"]}+    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+     ["2008/06/03 eat & shop           assets:cash                     $-2          $-2"+     ]++  ,"postings report with display expression" ~:+   do +    j <- samplejournal+    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"]+    "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"]+    "d=[2008/6/2]"  `gives` ["2008/06/02"]+    "d>=[2008/6/2]" `gives` ["2008/06/02","2008/06/03","2008/12/31"]+    "d>[2008/6/2]"  `gives` ["2008/06/03","2008/12/31"]++  ,"postings report with period expression" ~:+   do +    j <- samplejournal+    let periodexpr `gives` dates = do+          j' <- samplejournal+          registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j') `is` dates+              where opts = defreportopts{period_=maybePeriod date1 periodexpr}+    ""     `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]+    "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]+    "2007" `gives` []+    "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"]+    "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"]+    "quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"]+    let opts = defreportopts{period_=maybePeriod date1 "yearly"}+    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+     ["2008/01/01 - 2008/12/31         assets:bank:saving               $1           $1"+     ,"                                assets:cash                     $-2          $-1"+     ,"                                expenses:food                    $1            0"+     ,"                                expenses:supplies                $1           $1"+     ,"                                income:gifts                    $-1            0"+     ,"                                income:salary                   $-1          $-1"+     ,"                                liabilities:debts                $1            0"+     ]+    let opts = defreportopts{period_=maybePeriod date1 "quarterly"}+    registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/10/01"]+    let opts = defreportopts{period_=maybePeriod date1 "quarterly",empty_=True}+    registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]++  ]++  , "postings report with depth arg" ~:+   do +    j <- samplejournal+    let opts = defreportopts{depth_=Just 2}+    (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines+     ["2008/01/01 income               assets:bank                      $1           $1"+     ,"                                income:salary                   $-1            0"+     ,"2008/06/01 gift                 assets:bank                      $1           $1"+     ,"                                income:gifts                    $-1            0"+     ,"2008/06/02 save                 assets:bank                      $1           $1"+     ,"                                assets:bank                     $-1            0"+     ,"2008/06/03 eat & shop           expenses:food                    $1           $1"+     ,"                                expenses:supplies                $1           $2"+     ,"                                assets:cash                     $-2            0"+     ,"2008/12/31 pay off              liabilities:debts                $1           $1"+     ,"                                assets:bank                     $-1            0"+     ]++-}+ ]+ totallabel = "Total" balancelabel = "Balance"  -- | Generate postings report line items.-postingsReportItems :: [Posting] -> Posting -> MixedAmount -> (MixedAmount -> MixedAmount -> MixedAmount) -> [PostingsReportItem]-postingsReportItems [] _ _ _ = []-postingsReportItems (p:ps) pprev b sumfn = i:(postingsReportItems ps p b' sumfn)+postingsReportItems :: [Posting] -> Posting -> Int -> MixedAmount -> (MixedAmount -> MixedAmount -> MixedAmount) -> [PostingsReportItem]+postingsReportItems [] _ _ _ _ = []+postingsReportItems (p:ps) pprev d b sumfn = i:(postingsReportItems ps p d b' sumfn)     where-      i = mkpostingsReportItem isfirst p b'+      i = mkpostingsReportItem isfirst p' b'+      p' = p{paccount=clipAccountName d $ paccount p}       isfirst = ptransaction p /= ptransaction pprev       b' = b `sumfn` pamount p --- | Generate one postings report line item, from a flag indicating--- whether to include transaction info, a posting, and the current running--- balance.+-- | Generate one postings report line item, given a flag indicating+-- whether to include transaction info, the posting, and the current+-- running balance. mkpostingsReportItem :: Bool -> Posting -> MixedAmount -> PostingsReportItem mkpostingsReportItem False p b = (Nothing, p, b) mkpostingsReportItem True p b = (ds, p, b)@@ -305,26 +505,31 @@  where   compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] --- | Clip the account names to the specified depth in a list of postings.-depthClipPostings :: Maybe Int -> [Posting] -> [Posting]-depthClipPostings depth = map (depthClipPosting depth)+-- -- | Clip the account names to the specified depth in a list of postings.+-- depthClipPostings :: Maybe Int -> [Posting] -> [Posting]+-- depthClipPostings depth = map (depthClipPosting depth) --- | Clip a posting's account name to the specified depth.-depthClipPosting :: Maybe Int -> Posting -> Posting-depthClipPosting Nothing p = p-depthClipPosting (Just d) p@Posting{paccount=a} = p{paccount=clipAccountName d a}+-- -- | Clip a posting's account name to the specified depth.+-- depthClipPosting :: Maybe Int -> Posting -> Posting+-- depthClipPosting Nothing p = p+-- depthClipPosting (Just d) p@Posting{paccount=a} = p{paccount=clipAccountName d a}  -- XXX confusing, refactor  -- | Convert a list of postings into summary postings. Summary postings -- are one per account per interval and aggregated to the specified depth -- if any.-summarisePostingsByInterval :: Interval -> Maybe Int -> Bool -> DateSpan -> [Posting] -> [Posting]+summarisePostingsByInterval :: Interval -> Int -> Bool -> DateSpan -> [Posting] -> [Posting] summarisePostingsByInterval interval depth empty reportspan ps = concatMap summarisespan $ splitSpan interval reportspan     where       summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s)       postingsinspan s = filter (isPostingInDateSpan s) ps +tests_summarisePostingsByInterval = [+  "summarisePostingsByInterval" ~: do+    summarisePostingsByInterval (Quarters 1) 99999 False (DateSpan Nothing Nothing) [] ~?= []+ ]+ -- | 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@@ -338,7 +543,7 @@ -- -- The showempty flag includes spans with no postings and also postings -- with 0 amount.-summarisePostingsInDateSpan :: DateSpan -> Maybe Int -> Bool -> [Posting] -> [Posting]+summarisePostingsInDateSpan :: DateSpan -> Int -> Bool -> [Posting] -> [Posting] summarisePostingsInDateSpan (DateSpan b e) depth showempty ps     | null ps && (isNothing b || isNothing e) = []     | null ps && showempty = [summaryp]@@ -354,9 +559,8 @@       anames = sort $ nub $ map paccount ps       -- aggregate balances by account, like journalToLedger, then do depth-clipping       (_,_,exclbalof,inclbalof) = groupPostings ps-      clippedanames = nub $ map (clipAccountName d) anames-      isclipped a = accountNameLevel a >= d-      d = fromMaybe 99999 $ depth+      clippedanames = nub $ map (clipAccountName depth) anames+      isclipped a = accountNameLevel a >= depth       balancetoshowfor a =           (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a) @@ -384,10 +588,10 @@  -- | Select transactions from the whole journal for a transactions report, -- with no \"current\" account. The end result is similar to--- "postingsReport" except it uses matchers and transaction-based report+-- "postingsReport" except it uses queries and transaction-based report -- items and the items are most recent first. Used by eg hledger-web's -- journal view.-journalTransactionsReport :: ReportOpts -> Journal -> Matcher -> TransactionsReport+journalTransactionsReport :: ReportOpts -> Journal -> Query -> TransactionsReport journalTransactionsReport _ Journal{jtxns=ts} m = (totallabel, items)    where      ts' = sortBy (comparing tdate) $ filter (not . null . tpostings) $ map (filterTransactionPostings m) ts@@ -410,44 +614,44 @@ -- Currently, reporting intervals are not supported, and report items are -- most recent first. Used by eg hledger-web's account register view. ---accountTransactionsReport :: ReportOpts -> Journal -> Matcher -> Matcher -> TransactionsReport-accountTransactionsReport opts j m thisacctmatcher = (label, items)+accountTransactionsReport :: ReportOpts -> Journal -> Query -> Query -> TransactionsReport+accountTransactionsReport opts j m thisacctquery = (label, items)  where      -- transactions affecting this account, in date order-     ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctmatcher) $ jtxns $+     ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctquery) $ jtxns $           journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j      -- starting balance: if we are filtering by a start date and nothing else,      -- the sum of postings to this account before that date; otherwise zero.-     (startbal,label) | matcherIsNull m                           = (nullmixedamt,        balancelabel)-                      | matcherIsStartDateOnly (effective_ opts) m = (sumPostings priorps, balancelabel)+     (startbal,label) | queryIsNull m                           = (nullmixedamt,        balancelabel)+                      | queryIsStartDateOnly (effective_ opts) m = (sumPostings priorps, balancelabel)                       | otherwise                                 = (nullmixedamt,        totallabel)                       where                         priorps = -- ltrace "priorps" $                                   filter (matchesPosting                                           (-- ltrace "priormatcher" $-                                           MatchAnd [thisacctmatcher, tostartdatematcher]))+                                           And [thisacctquery, tostartdatequery]))                                          $ transactionsPostings ts-                        tostartdatematcher = MatchDate (DateSpan Nothing startdate)-                        startdate = matcherStartDate (effective_ opts) m-     items = reverse $ accountTransactionsReportItems m (Just thisacctmatcher) startbal negate ts+                        tostartdatequery = Date (DateSpan Nothing startdate)+                        startdate = queryStartDate (effective_ opts) m+     items = reverse $ accountTransactionsReportItems m (Just thisacctquery) startbal negate ts  -- | Generate transactions report items from a list of transactions,--- using the provided query and current account matchers, starting balance,+-- using the provided query and current account queries, starting balance, -- sign-setting function and balance-summing function.-accountTransactionsReportItems :: Matcher -> Maybe Matcher -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem]+accountTransactionsReportItems :: Query -> Maybe Query -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem] accountTransactionsReportItems _ _ _ _ [] = []-accountTransactionsReportItems matcher thisacctmatcher bal signfn (t:ts) =+accountTransactionsReportItems query thisacctquery bal signfn (t:ts) =     -- This is used for both accountTransactionsReport and journalTransactionsReport,     -- which makes it a bit overcomplicated     case i of Just i' -> i':is               Nothing -> is     where-      tmatched@Transaction{tpostings=psmatched} = filterTransactionPostings matcher t-      (psthisacct,psotheracct) = case thisacctmatcher of Just m  -> partition (matchesPosting m) psmatched-                                                         Nothing -> ([],psmatched)+      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 thisacctmatcher = summarisePostings psmatched -- journal register+      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@@ -457,7 +661,7 @@                  where                   a = signfn amt                   b = bal + a-      is = accountTransactionsReportItems matcher thisacctmatcher bal' signfn ts+      is = accountTransactionsReportItems query thisacctquery bal' signfn ts  -- | Generate a short readable summary of some postings, like -- "from (negatives) to (positives)".@@ -474,7 +678,7 @@ summarisePostingAccounts :: [Posting] -> String summarisePostingAccounts = intercalate ", " . map accountLeafName . nub . map paccount -filterTransactionPostings :: Matcher -> Transaction -> Transaction+filterTransactionPostings :: Query -> Transaction -> Transaction filterTransactionPostings m t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps}  -------------------------------------------------------------------------------@@ -491,29 +695,18 @@                           ,MixedAmount) -- account balance, includes subs unless --flat is present  -- | Select accounts, and get their balances at the end of the selected--- period, and misc. display information, for an accounts report. Used by--- eg hledger's balance command.-accountsReport :: ReportOpts -> FilterSpec -> Journal -> AccountsReport-accountsReport opts filterspec j = accountsReport' opts j (journalToLedger filterspec)---- | Select accounts, and get their balances at the end of the selected--- period, and misc. display information, for an accounts report. Like--- "accountsReport" but uses the new matchers. Used by eg hledger-web's--- accounts sidebar.-accountsReport2 :: ReportOpts -> Matcher -> Journal -> AccountsReport-accountsReport2 opts matcher j = accountsReport' opts j (journalToLedger2 matcher)---- Accounts report helper.-accountsReport' :: ReportOpts -> Journal -> (Journal -> Ledger) -> AccountsReport-accountsReport' opts j jtol = (items, total)+-- period, and misc. display information, for an accounts report.+accountsReport :: ReportOpts -> Query -> Journal -> AccountsReport+accountsReport opts query j = (items, total)      where-      items = map mkitem interestingaccts+      -- don't do depth filtering until the end+      q' = filterQuery (not . queryIsDepth) query+      l =  journalToLedger q' $ journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j+      acctnames = filter (query `matchesAccount`) $ journalAccountNames j       interestingaccts | no_elide_ opts = acctnames                        | otherwise = filter (isInteresting opts l) acctnames-      acctnames = sort $ tail $ flatten $ treemap aname accttree-      accttree = ledgerAccountTree (fromMaybe 99999 $ depth_ opts) l+      items = map mkitem interestingaccts       total = sum $ map abalance $ ledgerTopAccounts l-      l =  jtol $ journalSelectingDateFromOpts opts $ journalSelectingAmountFromOpts opts j        -- | Get data for one balance report line item.       mkitem :: AccountName -> AccountsReportItem@@ -530,6 +723,223 @@                  | otherwise = abalance acct                  where acct = ledgerAccount l a +tests_accountsReport = [+  "accountsReport" ~: do+   let (opts,journal) `gives` r = do+         let (eitems, etotal) = r+             (aitems, atotal) = accountsReport 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+          +   -- "accounts report with no args" ~:+   (defreportopts, nulljournal) `gives` ([], Mixed [nullamt])+   (defreportopts, samplejournal) `gives`+    ([+      ("assets","assets",0, amount' "$-1.00")+     ,("assets:bank:saving","bank:saving",1, amount' "$1.00")+     ,("assets:cash","cash",1, amount' "$-2.00")+     ,("expenses","expenses",0, amount' "$2.00")+     ,("expenses:food","food",1, amount' "$1.00")+     ,("expenses:supplies","supplies",1, amount' "$1.00")+     ,("income","income",0, amount' "$-2.00")+     ,("income:gifts","gifts",1, amount' "$-1.00")+     ,("income:salary","salary",1, amount' "$-1.00")+     ,("liabilities:debts","liabilities:debts",0, amount' "$1.00")+     ],+     Mixed [nullamt])++   -- "accounts report can be limited with --depth=N" ~:+   (defreportopts{depth_=Just 1}, samplejournal) `gives`+    ([+      ("assets",      "assets",      0, amount' "$-1.00")+     ,("expenses",    "expenses",    0, amount'  "$2.00")+     ,("income",      "income",      0, amount' "$-2.00")+     ,("liabilities", "liabilities", 0, amount'  "$1.00")+     ],+     Mixed [nullamt])++   -- or with depth:N+   (defreportopts{query_="depth:1"}, samplejournal) `gives`+    ([+      ("assets",      "assets",      0, amount' "$-1.00")+     ,("expenses",    "expenses",    0, amount'  "$2.00")+     ,("income",      "income",      0, amount' "$-2.00")+     ,("liabilities", "liabilities", 0, amount'  "$1.00")+     ],+     Mixed [nullamt])++   -- with a date span+   (defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives`+    ([],+     Mixed [nullamt])+   (defreportopts{query_="edate:'in 2009'"}, samplejournal2) `gives`+    ([+      ("assets:bank:checking","assets:bank:checking",0,amount' "$1.00")+     ,("income:salary","income:salary",0,amount' "$-1.00")+     ],+     Mixed [nullamt])+++{-+    ,"accounts report with account pattern o" ~:+     defreportopts{patterns_=["o"]} `gives`+     ["                  $1  expenses:food"+     ,"                 $-2  income"+     ,"                 $-1    gifts"+     ,"                 $-1    salary"+     ,"--------------------"+     ,"                 $-1"+     ]++    ,"accounts report with account pattern o and --depth 1" ~:+     defreportopts{patterns_=["o"],depth_=Just 1} `gives`+     ["                  $1  expenses"+     ,"                 $-2  income"+     ,"--------------------"+     ,"                 $-1"+     ]++    ,"accounts report with account pattern a" ~:+     defreportopts{patterns_=["a"]} `gives`+     ["                 $-1  assets"+     ,"                  $1    bank:saving"+     ,"                 $-2    cash"+     ,"                 $-1  income:salary"+     ,"                  $1  liabilities:debts"+     ,"--------------------"+     ,"                 $-1"+     ]++    ,"accounts report with account pattern e" ~:+     defreportopts{patterns_=["e"]} `gives`+     ["                 $-1  assets"+     ,"                  $1    bank:saving"+     ,"                 $-2    cash"+     ,"                  $2  expenses"+     ,"                  $1    food"+     ,"                  $1    supplies"+     ,"                 $-2  income"+     ,"                 $-1    gifts"+     ,"                 $-1    salary"+     ,"                  $1  liabilities:debts"+     ,"--------------------"+     ,"                   0"+     ]++    ,"accounts report with unmatched parent of two matched subaccounts" ~: +     defreportopts{patterns_=["cash","saving"]} `gives`+     ["                 $-1  assets"+     ,"                  $1    bank:saving"+     ,"                 $-2    cash"+     ,"--------------------"+     ,"                 $-1"+     ]++    ,"accounts report with multi-part account name" ~: +     defreportopts{patterns_=["expenses:food"]} `gives`+     ["                  $1  expenses:food"+     ,"--------------------"+     ,"                  $1"+     ]++    ,"accounts report with negative account pattern" ~:+     defreportopts{patterns_=["not:assets"]} `gives`+     ["                  $2  expenses"+     ,"                  $1    food"+     ,"                  $1    supplies"+     ,"                 $-2  income"+     ,"                 $-1    gifts"+     ,"                 $-1    salary"+     ,"                  $1  liabilities:debts"+     ,"--------------------"+     ,"                  $1"+     ]++    ,"accounts report negative account pattern always matches full name" ~: +     defreportopts{patterns_=["not:e"]} `gives`+     ["--------------------"+     ,"                   0"+     ]++    ,"accounts report negative patterns affect totals" ~: +     defreportopts{patterns_=["expenses","not:food"]} `gives`+     ["                  $1  expenses:supplies"+     ,"--------------------"+     ,"                  $1"+     ]++    ,"accounts report with -E shows zero-balance accounts" ~:+     defreportopts{patterns_=["assets"],empty_=True} `gives`+     ["                 $-1  assets"+     ,"                  $1    bank"+     ,"                   0      checking"+     ,"                  $1      saving"+     ,"                 $-2    cash"+     ,"--------------------"+     ,"                 $-1"+     ]++    ,"accounts report with cost basis" ~: do+       j <- (readJournal Nothing Nothing Nothing $ unlines+              [""+              ,"2008/1/1 test           "+              ,"  a:b          10h @ $50"+              ,"  c:d                   "+              ]) >>= either error' return+       let j' = journalCanonicaliseAmounts $ journalConvertAmountsToCost j -- enable cost basis adjustment+       accountsReportAsText defreportopts (accountsReport defreportopts Any j') `is`+         ["                $500  a:b"+         ,"               $-500  c:d"+         ,"--------------------"+         ,"                   0"+         ]+-}+ ]++Right samplejournal2 = journalBalanceTransactions $ Journal+          [] +          [] +          [+           txnTieKnot $ Transaction {+             tdate=parsedate "2008/01/01",+             teffectivedate=Just $ parsedate "2009/01/01",+             tstatus=False,+             tcode="",+             tdescription="income",+             tcomment="",+             ttags=[],+             tpostings=[+              Posting {+                pstatus=False,+                paccount="assets:bank:checking",+                pamount=(Mixed [dollars 1]),+                pcomment="",+                ptype=RegularPosting,+                ptags=[],+                ptransaction=Nothing+              },+              Posting {+                pstatus=False,+                paccount="income:salary",+                pamount=(missingmixedamt),+                pcomment="",+                ptype=RegularPosting,+                ptags=[],+                ptransaction=Nothing+              }+             ],+             tpreceding_comment_lines=""+           }+          ]+          []+          []+          ""+          nullctx+          []+          (TOD 0 0)+ exclusiveBalance :: Account -> MixedAmount exclusiveBalance = sumPostings . apostings @@ -555,7 +965,7 @@     | numinterestingsubs < 2 && zerobalance && not emptyflag = False     | otherwise = True     where-      atmaxdepth = isJust d && Just (accountNameLevel a) == d where d = depth_ opts+      atmaxdepth = accountNameLevel a == depthFromOpts opts       emptyflag = empty_ opts       acct = ledgerAccount l a       zerobalance = isZeroMixedAmount inclbalance where inclbalance = abalance acct@@ -565,15 +975,29 @@             isInterestingTree = treeany (isInteresting opts l . aname)             subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a --------------------------------------------------------------------------------+tests_isInterestingIndented = [+  "isInterestingIndented" ~: do +   let (opts, journal, acctname) `gives` r = isInterestingIndented opts l acctname `is` r+          where l = journalToLedger (queryFromOpts nulldate opts) journal+     +   (defreportopts, samplejournal, "expenses") `gives` True+ ] -tests_Hledger_Reports :: Test-tests_Hledger_Reports = TestList- [+depthFromOpts :: ReportOpts -> Int+depthFromOpts opts = min (fromMaybe 99999 $ depth_ opts) (queryDepth $ queryFromOpts nulldate opts) -  "summarisePostingsByInterval" ~: do-    summarisePostingsByInterval (Quarters 1) Nothing False (DateSpan Nothing Nothing) [] ~?= []+------------------------------------------------------------------------------- +tests_Hledger_Reports :: Test+tests_Hledger_Reports = TestList $+    tests_queryFromOpts+ ++ tests_queryOptsFromOpts+ ++ tests_entriesReport+ ++ tests_summarisePostingsByInterval+ ++ tests_postingsReport+ ++ tests_isInterestingIndented+ ++ tests_accountsReport+ ++ [   -- ,"summarisePostingsInDateSpan" ~: do   --   let gives (b,e,depth,showempty,ps) =   --           (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`)

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-|  Standard imports and utilities which are useful everywhere, or needed low@@ -19,12 +20,13 @@                           -- module Text.Printf,                           ---- all of this one:                           module Hledger.Utils,-                          Debug.Trace.trace-                          ---- and this for i18n - needs to be done in each module I think:-                          -- module Hledger.Utils.UTF8+                          Debug.Trace.trace,+                          -- module Hledger.Utils.UTF8IOCompat+                          SystemString,fromSystemString,toSystemString,error',userError'+                          -- the rest need to be done in each module I think                           ) where-import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded)+import Control.Monad.Error import Data.Char import Data.List import Data.Maybe@@ -32,15 +34,17 @@ import Data.Time.LocalTime import Data.Tree import Debug.Trace-import System.Info (os)+import System.Directory (getHomeDirectory)+import System.FilePath(takeDirectory,combine) import Test.HUnit import Text.ParserCombinators.Parsec import Text.Printf import Text.RegexPR -- import qualified Data.Map as Map -- --- import Prelude hiding (readFile,writeFile,getContents,putStr,putStrLn)--- import Hledger.Utils.UTF8+-- 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')  -- strings @@ -70,8 +74,13 @@ quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s                 | not $ any (`elem` s) whitespacechars = s                 | otherwise = "'"++escapeSingleQuotes s++"'"-                  where escapeSingleQuotes = regexReplace "'" "\'" +escapeSingleQuotes :: String -> String+escapeSingleQuotes = regexReplace "'" "\'"++escapeQuotes :: String -> String+escapeQuotes = regexReplace "([\"'])" "\\1"+ -- | Quote-aware version of words - don't split on spaces which are inside quotes. -- NB correctly handles "a'b" but not "''a''". words' :: String -> [String]@@ -87,6 +96,7 @@ unwords' :: [String] -> String unwords' = unwords . map singleQuoteIfNeeded +-- | Single-quote this string if it contains whitespace or double-quotes singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"                       | otherwise = s @@ -180,41 +190,6 @@       fit w = take w . (++ repeat ' ')       blankline = replicate w ' ' --- encoded platform strings---- | A platform string is a string value from or for the operating system,--- such as a file path or command-line argument (or environment variable's--- name or value ?). On some platforms (such as unix) these are not real--- unicode strings but have some encoding such as UTF-8. This alias does--- no type enforcement but aids code clarity.-type PlatformString = String---- | Convert a possibly encoded platform string to a real unicode string.--- We decode the UTF-8 encoding recommended for unix systems--- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)--- and leave anything else unchanged.-fromPlatformString :: PlatformString -> String-fromPlatformString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s---- | Convert a unicode string to a possibly encoded platform string.--- On unix we encode with the recommended UTF-8--- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html)--- and elsewhere we leave it unchanged.-toPlatformString :: String -> PlatformString-toPlatformString = case os of-                     "unix" -> UTF8.encodeString-                     "linux" -> UTF8.encodeString-                     "darwin" -> UTF8.encodeString-                     _ -> id---- | A version of error that's better at displaying unicode.-error' :: String -> a-error' = error . toPlatformString---- | A version of userError that's better at displaying unicode.-userError' :: String -> IOError-userError' = userError . toPlatformString- -- math  difforzero :: (Num a, Ord a) => a -> a -> a@@ -378,21 +353,21 @@ -- testing  -- | Get a Test's label, or the empty string.-tname :: Test -> String-tname (TestLabel n _) = n-tname _ = ""+testName :: Test -> String+testName (TestLabel n _) = n+testName _ = ""  -- | Flatten a Test containing TestLists into a list of single tests.-tflatten :: Test -> [Test]-tflatten (TestLabel _ t@(TestList _)) = tflatten t-tflatten (TestList ts) = concatMap tflatten ts-tflatten t = [t]+flattenTests :: Test -> [Test]+flattenTests (TestLabel _ t@(TestList _)) = flattenTests t+flattenTests (TestList ts) = concatMap flattenTests ts+flattenTests t = [t]  -- | Filter TestLists in a Test, recursively, preserving the structure.-tfilter :: (Test -> Bool) -> Test -> Test-tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts)-tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts-tfilter _ t = t+filterTests :: (Test -> Bool) -> Test -> Test+filterTests p (TestLabel l ts) = TestLabel l (filterTests p ts)+filterTests p (TestList ts) = TestList $ filter (any p . flattenTests) $ map (filterTests p) ts+filterTests _ t = t  -- | Simple way to assert something is some expected value, with no label. is :: (Eq a, Show a) => a -> a -> Assertion@@ -425,3 +400,18 @@ -- | 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++-- | Convert a possibly relative, possibly tilde-containing file path to an absolute one.+-- using the current directory from a parsec source position. ~username is not supported.+expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath+expandPath pos fp = liftM mkAbsolute (expandHome fp)+  where+    mkAbsolute = combine (takeDirectory (sourceName pos))+    expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory+                                                      return $ homedir ++ drop 1 inname+                      | otherwise                = return inname++firstJust ms = case dropWhile (==Nothing) ms of+    [] -> Nothing+    (md:_) -> md+

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

@@ -0,0 +1,122 @@+{-# LANGUAGE CPP #-}+{- |++UTF-8 aware string IO functions that will work across multiple platforms+and GHC versions. Includes code from Text.Pandoc.UTF8 ((C) 2010 John+MacFarlane).++Example usage:++ import Prelude hiding (readFile,writeFile,appendFile,getContents,putStr,putStrLn)+ import UTF8IOCompat   (readFile,writeFile,appendFile,getContents,putStr,putStrLn)+ import UTF8IOCompat   (SystemString,fromSystemString,toSystemString,error',userError')++-}++module Hledger.Utils.UTF8IOCompat (+  readFile,+  writeFile,+  appendFile,+  getContents,+  hGetContents,+  putStr,+  putStrLn,+  hPutStr,+  hPutStrLn,+  --+  SystemString,+  fromSystemString,+  toSystemString,+  error',+  userError',+)+where++import Control.Monad (liftM)+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.Char8 as B8+import qualified Data.ByteString.Lazy.UTF8 as U8 (toString, fromString)+import Prelude hiding (readFile, writeFile, appendFile, getContents, putStr, putStrLn)+import System.IO (Handle)+#if __GLASGOW_HASKELL__ < 702+import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded)+import System.Info (os)+#endif++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 (U8.toString . stripBOM) . B.readFile++writeFile :: FilePath -> String -> IO ()+writeFile f = B.writeFile f . U8.fromString++appendFile :: FilePath -> String -> IO ()+appendFile f = B.appendFile f . U8.fromString++getContents :: IO String+getContents = liftM (U8.toString . stripBOM) B.getContents++hGetContents :: Handle -> IO String+hGetContents h = liftM (U8.toString . stripBOM) (B.hGetContents h)++putStr :: String -> IO ()+putStr = bs_putStr . U8.fromString++putStrLn :: String -> IO ()+putStrLn = bs_putStrLn . U8.fromString++hPutStr :: Handle -> String -> IO ()+hPutStr h = bs_hPutStr h . U8.fromString++hPutStrLn :: Handle -> String -> IO ()+hPutStrLn h = bs_hPutStrLn h . U8.fromString++-- span GHC versions including 6.12.3 - 7.4.1:+bs_putStr         = B8.putStr+bs_putStrLn       = B8.putStrLn+bs_hPutStr        = B8.hPut+bs_hPutStrLn h bs = B8.hPut h bs >> B8.hPut h (B.singleton 0x0a)+++-- | A string received from or being passed to the operating system, such+-- as a file path, command-line argument, or environment variable name or+-- value. With GHC versions before 7.2 on some platforms (posix) these are+-- typically encoded. When converting, we assume the encoding is UTF-8 (cf+-- <http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html#UTF8>).+type SystemString = String++-- | Convert a system string to an ordinary string, decoding from UTF-8 if+-- it appears to be UTF8-encoded and GHC version is less than 7.2.+fromSystemString :: SystemString -> String+#if __GLASGOW_HASKELL__ < 702+fromSystemString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s+#else+fromSystemString = id+#endif++-- | Convert a unicode string to a system string, encoding with UTF-8 if+-- we are on a posix platform with GHC < 7.2.+toSystemString :: String -> SystemString+#if __GLASGOW_HASKELL__ < 702+toSystemString = case os of+                     "unix" -> UTF8.encodeString+                     "linux" -> UTF8.encodeString+                     "darwin" -> UTF8.encodeString+                     _ -> id+#else+toSystemString = id+#endif++-- | A SystemString-aware version of error.+error' :: String -> a+error' = error . toSystemString++-- | A SystemString-aware version of userError.+userError' :: String -> IOError+userError' = userError . toSystemString

@@ -1,5 +1,5 @@ name:           hledger-lib-version: 0.17+version: 0.18 category:       Finance synopsis:       Core data types, parsers and utilities for the hledger accounting tool. description:@@ -17,8 +17,8 @@ homepage:       http://hledger.org bug-reports:    http://code.google.com/p/hledger/issues stability:      beta-tested-with:    GHC==7.0, GHC==7.2-cabal-version:  >= 1.6+tested-with:    GHC==7.0.4, GHC==7.2.2, GHC==7.4.1+cabal-version:  >= 1.8 build-type:     Simple -- data-dir:       data -- data-files:@@ -39,25 +39,27 @@                   Hledger.Data.Amount                   Hledger.Data.Commodity                   Hledger.Data.Dates-                  Hledger.Data.Transaction+                  Hledger.Data.FormatStrings                   Hledger.Data.Journal                   Hledger.Data.Ledger-                  Hledger.Data.Matching                   Hledger.Data.Posting                   Hledger.Data.TimeLog+                  Hledger.Data.Transaction                   Hledger.Data.Types+                  Hledger.Query                   Hledger.Read+                  Hledger.Read.CsvReader                   Hledger.Read.JournalReader                   Hledger.Read.TimelogReader-                  Hledger.Read.Utils                   Hledger.Reports                   Hledger.Utils-                  Hledger.Utils.UTF8+                  Hledger.Utils.UTF8IOCompat   Build-Depends:                   base >= 3 && < 5                  ,bytestring                  ,cmdargs >= 0.9.1   && < 0.10                  ,containers+                 ,csv                  ,directory                  ,filepath                  ,mtl@@ -66,6 +68,7 @@                  ,parsec                  ,regexpr >= 0.5.1                  ,safe >= 0.2+                 ,shakespeare-text >= 1.0 && < 1.1                  ,split == 0.1.*                  ,time                  ,utf8-string >= 0.3.5 && < 0.4