diff --git a/Hledger.hs b/Hledger.hs --- a/Hledger.hs +++ b/Hledger.hs @@ -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 + ] diff --git a/Hledger/Data.hs b/Hledger/Data.hs --- a/Hledger/Data.hs +++ b/Hledger/Data.hs @@ -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 diff --git a/Hledger/Data/Account.hs b/Hledger/Data/Account.hs --- a/Hledger/Data/Account.hs +++ b/Hledger/Data/Account.hs @@ -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 diff --git a/Hledger/Data/AccountName.hs b/Hledger/Data/AccountName.hs --- a/Hledger/Data/AccountName.hs +++ b/Hledger/Data/AccountName.hs @@ -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 diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -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]} diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -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 diff --git a/Hledger/Data/FormatStrings.hs b/Hledger/Data/FormatStrings.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/FormatStrings.hs @@ -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" + ] + ] diff --git a/Hledger/Data/Journal.hs b/Hledger/Data/Journal.hs --- a/Hledger/Data/Journal.hs +++ b/Hledger/Data/Journal.hs @@ -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 . +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 . +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"] + -- ] diff --git a/Hledger/Data/Ledger.hs b/Hledger/Data/Ledger.hs --- a/Hledger/Data/Ledger.hs +++ b/Hledger/Data/Ledger.hs @@ -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 diff --git a/Hledger/Data/Matching.hs b/Hledger/Data/Matching.hs deleted file mode 100644 --- a/Hledger/Data/Matching.hs +++ /dev/null @@ -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'") - - ] diff --git a/Hledger/Data/Posting.hs b/Hledger/Data/Posting.hs --- a/Hledger/Data/Posting.hs +++ b/Hledger/Data/Posting.hs @@ -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') diff --git a/Hledger/Data/TimeLog.hs b/Hledger/Data/TimeLog.hs --- a/Hledger/Data/TimeLog.hs +++ b/Hledger/Data/TimeLog.hs @@ -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 [ diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -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) - ] + ]] diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -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 diff --git a/Hledger/Query.hs b/Hledger/Query.hs new file mode 100644 --- /dev/null +++ b/Hledger/Query.hs @@ -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 + diff --git a/Hledger/Read.hs b/Hledger/Read.hs --- a/Hledger/Read.hs +++ b/Hledger/Read.hs @@ -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 ] diff --git a/Hledger/Read/CsvReader.hs b/Hledger/Read/CsvReader.hs new file mode 100644 --- /dev/null +++ b/Hledger/Read/CsvReader.hs @@ -0,0 +1,584 @@ +{-| + +A reader for the CSV data format. Uses an extra rules file +() 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") + -- ] + -- }) + + ] diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs --- a/Hledger/Read/JournalReader.hs +++ b/Hledger/Read/JournalReader.hs @@ -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 +(). hledger's journal +format is a compatible subset of c++ ledger's +(), 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" diff --git a/Hledger/Read/TimelogReader.hs b/Hledger/Read/TimelogReader.hs --- a/Hledger/Read/TimelogReader.hs +++ b/Hledger/Read/TimelogReader.hs @@ -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 +(). 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) diff --git a/Hledger/Read/Utils.hs b/Hledger/Read/Utils.hs deleted file mode 100644 --- a/Hledger/Read/Utils.hs +++ /dev/null @@ -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 (/='.') diff --git a/Hledger/Reports.hs b/Hledger/Reports.hs --- a/Hledger/Reports.hs +++ b/Hledger/Reports.hs @@ -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`) diff --git a/Hledger/Utils.hs b/Hledger/Utils.hs --- a/Hledger/Utils.hs +++ b/Hledger/Utils.hs @@ -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 + diff --git a/Hledger/Utils/UTF8.hs b/Hledger/Utils/UTF8.hs deleted file mode 100644 --- a/Hledger/Utils/UTF8.hs +++ /dev/null @@ -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 - -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 - 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") diff --git a/Hledger/Utils/UTF8IOCompat.hs b/Hledger/Utils/UTF8IOCompat.hs new file mode 100644 --- /dev/null +++ b/Hledger/Utils/UTF8IOCompat.hs @@ -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 +-- ). +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 diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -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