diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,9 @@ +API-ish changes in hledger-lib. For user-visible changes, see the hledger changelog. + +0.23 (2014/5/1) + +- orDatesFrom -> spanDefaultsFrom + 0.22.2 (2014/4/16) - display years before 1000 with four digits, not three diff --git a/Hledger/Data.hs b/Hledger/Data.hs --- a/Hledger/Data.hs +++ b/Hledger/Data.hs @@ -16,6 +16,7 @@ module Hledger.Data.Journal, module Hledger.Data.Ledger, module Hledger.Data.Posting, + module Hledger.Data.RawOptions, module Hledger.Data.TimeLog, module Hledger.Data.Transaction, module Hledger.Data.Types, @@ -32,10 +33,12 @@ import Hledger.Data.Journal import Hledger.Data.Ledger import Hledger.Data.Posting +import Hledger.Data.RawOptions import Hledger.Data.TimeLog import Hledger.Data.Transaction import Hledger.Data.Types +tests_Hledger_Data :: Test tests_Hledger_Data = TestList [ tests_Hledger_Data_Account diff --git a/Hledger/Data/Account.hs b/Hledger/Data/Account.hs --- a/Hledger/Data/Account.hs +++ b/Hledger/Data/Account.hs @@ -10,6 +10,7 @@ module Hledger.Data.Account where import Data.List +import Data.Maybe import qualified Data.Map as M import Safe (headMay, lookupJustDef) import Test.HUnit @@ -24,9 +25,10 @@ -- deriving instance Show Account instance Show Account where - show Account{..} = printf "Account %s (boring:%s, ebalance:%s, ibalance:%s)" - aname + show Account{..} = printf "Account %s (boring:%s, postings:%d, ebalance:%s, ibalance:%s)" + aname (if aboring then "y" else "n" :: String) + anumpostings (showMixedAmount aebalance) (showMixedAmount aibalance) @@ -44,6 +46,7 @@ { aname = "" , aparent = Nothing , asubs = [] + , anumpostings = 0 , aebalance = nullmixedamt , aibalance = nullmixedamt , aboring = False @@ -57,10 +60,12 @@ let acctamts = [(paccount p,pamount p) | p <- ps] grouped = groupBy (\a b -> fst a == fst b) $ sort $ acctamts + counted = [(a, length acctamts) | acctamts@((a,_):_) <- grouped] summed = map (\as@((aname,_):_) -> (aname, sum $ map snd as)) grouped -- always non-empty nametree = treeFromPaths $ map (expandAccountName . fst) summed acctswithnames = nameTreeToAccount "root" nametree - acctswithebals = mapAccounts setebalance acctswithnames where setebalance a = a{aebalance=lookupJustDef nullmixedamt (aname a) summed} + acctswithnumps = mapAccounts setnumps acctswithnames where setnumps a = a{anumpostings=fromMaybe 0 $ lookup (aname a) counted} + acctswithebals = mapAccounts setebalance acctswithnumps where setebalance a = a{aebalance=lookupJustDef nullmixedamt (aname a) summed} acctswithibals = sumAccounts acctswithebals acctswithparents = tieAccountParents acctswithibals acctsflattened = flattenAccounts acctswithparents @@ -115,15 +120,52 @@ where subs = map (clipAccounts (d-1)) $ asubs a +-- | Remove subaccounts below the specified depth, aggregating their balance at the depth limit +-- (accounts at the depth limit will have any sub-balances merged into their exclusive balance). +clipAccountsAndAggregate :: Int -> [Account] -> [Account] +clipAccountsAndAggregate d as = combined + where + clipped = [a{aname=clipAccountName d $ aname a} | a <- as] + combined = [a{aebalance=sum (map aebalance same)} + | same@(a:_) <- groupBy (\a1 a2 -> aname a1 == aname a2) clipped] +{- +test cases, assuming d=1: + +assets:cash 1 1 +assets:checking 1 1 +-> +as: [assets:cash 1 1, assets:checking 1 1] +clipped: [assets 1 1, assets 1 1] +combined: [assets 2 2] + +assets 0 2 + assets:cash 1 1 + assets:checking 1 1 +-> +as: [assets 0 2, assets:cash 1 1, assets:checking 1 1] +clipped: [assets 0 2, assets 1 1, assets 1 1] +combined: [assets 2 2] + +assets 0 2 + assets:bank 1 2 + assets:bank:checking 1 1 +-> +as: [assets 0 2, assets:bank 1 2, assets:bank:checking 1 1] +clipped: [assets 0 2, assets 1 2, assets 1 1] +combined: [assets 2 2] + +-} + -- | Remove all leaf accounts and subtrees matching a predicate. pruneAccounts :: (Account -> Bool) -> Account -> Maybe Account pruneAccounts p = headMay . prune where prune a - | null prunedsubs = if p a then [] else [a] - | otherwise = [a{asubs=prunedsubs}] + | null prunedsubs = if p a then [] else [a'] + | otherwise = [a'] where prunedsubs = concatMap prune $ asubs a + a' = a{asubs=prunedsubs} -- | Flatten an account tree into a list, which is sometimes -- convenient. Note since accounts link to their parents/subs, the diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -117,9 +117,9 @@ instance Show Amount where show _a@Amount{..} - -- debugLevel < 3 = showAmountWithoutPrice a - -- debugLevel < 6 = showAmount a - | debugLevel < 9 = + -- debugLevel < 2 = showAmountWithoutPrice a + -- debugLevel < 3 = showAmount a + | debugLevel < 6 = printf "Amount {acommodity=%s, aquantity=%s, ..}" (show acommodity) (show aquantity) | otherwise = --showAmountDebug a printf "Amount {acommodity=%s, aquantity=%s, aprice=%s, astyle=%s}" (show acommodity) (show aquantity) (showPriceDebug aprice) (show astyle) @@ -332,7 +332,7 @@ instance Show MixedAmount where show - -- debugLevel < 3 = intercalate "\\n" . lines . showMixedAmountWithoutPrice + | debugLevel < 3 = intercalate "\\n" . lines . showMixedAmountWithoutPrice -- debugLevel < 6 = intercalate "\\n" . lines . showMixedAmount | otherwise = showMixedAmountDebug diff --git a/Hledger/Data/Commodity.hs b/Hledger/Data/Commodity.hs --- a/Hledger/Data/Commodity.hs +++ b/Hledger/Data/Commodity.hs @@ -17,8 +17,8 @@ import Hledger.Utils --- characters than can't be in a non-quoted commodity symbol -nonsimplecommoditychars = "0123456789-.@;\n \"{}=" :: String +-- characters that may not be used in a non-quoted commodity symbol +nonsimplecommoditychars = "0123456789-+.@;\n \"{}=" :: String quoteCommoditySymbolIfNeeded s | any (`elem` nonsimplecommoditychars) s = "\"" ++ s ++ "\"" | otherwise = s diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -45,9 +45,9 @@ spansSpan, spanIntersect, spansIntersect, + spanDefaultsFrom, spanUnion, spansUnion, - orDatesFrom, smartdate, splitSpan, fixSmartDate, @@ -77,17 +77,20 @@ import Hledger.Data.Types import Hledger.Utils + +-- Help ppShow parse and line-wrap DateSpans better in debug output. +instance Show DateSpan where + show (DateSpan s1 s2) = "DateSpan \"" ++ show s1 ++ "\" \"" ++ show s2 ++ "\"" + showDate :: Day -> String showDate = formatTime defaultTimeLocale "%0C%y/%m/%d" showDateSpan (DateSpan from to) = concat - [maybe "" showdate from + [maybe "" showDate from ,"-" - ,maybe "" (showdate . prevday) to + ,maybe "" (showDate . prevday) to ] - where - showdate = formatTime defaultTimeLocale "%C%y/%m/%d" -- | Get the current local date. getCurrentDay :: IO Day @@ -116,11 +119,14 @@ spanEnd :: DateSpan -> Maybe Day spanEnd (DateSpan _ d) = d +-- might be useful later: http://en.wikipedia.org/wiki/Allen%27s_interval_algebra + -- | Get overall span enclosing multiple sequentially ordered spans. spansSpan :: [DateSpan] -> DateSpan spansSpan spans = DateSpan (maybe Nothing spanStart $ headMay spans) (maybe Nothing spanEnd $ lastMay spans) --- | Split a DateSpan into one or more consecutive spans at the specified interval. +-- | Split a DateSpan into one or more consecutive whole spans of the specified length which enclose it. +-- If no interval is specified, the original span is returned. splitSpan :: Interval -> DateSpan -> [DateSpan] splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] splitSpan NoInterval s = [s] @@ -165,14 +171,6 @@ spanContainsDate (DateSpan (Just b) Nothing) d = d >= b spanContainsDate (DateSpan (Just b) (Just e)) d = d >= b && d < e --- | Combine two datespans, filling any unspecified dates in the first --- with dates from the second. Not a clip operation, just uses the --- second's start/end dates as defaults when the first does not --- specify them. -orDatesFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b - 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 @@ -184,6 +182,12 @@ b = latest b1 b2 e = earliest e1 e2 +-- | Fill any unspecified dates in the first span with the dates from +-- the second one. Sort of a one-way spanIntersect. +spanDefaultsFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b + where a = if isJust a1 then a1 else a2 + b = if isJust b1 then b1 else b2 + -- | Calculate the union of a number of datespans. spansUnion [] = nulldatespan spansUnion [d] = d @@ -674,11 +678,11 @@ ,"period expressions" ~: do let todaysdate = parsedate "2008/11/26" let str `gives` result = show (parsewith (periodexpr todaysdate) str) `is` ("Right " ++ result) - "from aug to oct" `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))" - "aug to oct" `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))" - "every 3 days in aug" `gives` "(Days 3,DateSpan (Just 2008-08-01) (Just 2008-09-01))" - "daily from aug" `gives` "(Days 1,DateSpan (Just 2008-08-01) Nothing)" - "every week to 2009" `gives` "(Weeks 1,DateSpan Nothing (Just 2009-01-01))" + "from aug to oct" `gives` "(NoInterval,DateSpan \"Just 2008-08-01\" \"Just 2008-10-01\")" + "aug to oct" `gives` "(NoInterval,DateSpan \"Just 2008-08-01\" \"Just 2008-10-01\")" + "every 3 days in aug" `gives` "(Days 3,DateSpan \"Just 2008-08-01\" \"Just 2008-09-01\")" + "daily from aug" `gives` "(Days 1,DateSpan \"Just 2008-08-01\" \"Nothing\")" + "every week to 2009" `gives` "(Weeks 1,DateSpan \"Nothing\" \"Just 2009-01-01\")" ,"splitSpan" ~: do let gives (interval, span) = (splitSpan interval span `is`) diff --git a/Hledger/Data/FormatStrings.hs b/Hledger/Data/FormatStrings.hs deleted file mode 100644 --- a/Hledger/Data/FormatStrings.hs +++ /dev/null @@ -1,118 +0,0 @@ -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 '%') - -formatStr :: GenParser Char st FormatString -formatStr = - formatField - <|> formatLiteral - -formatStrings :: GenParser Char st [FormatString] -formatStrings = many formatStr - -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,3 +1,4 @@ +-- {-# LANGUAGE CPP #-} {-| A 'Journal' is a set of transactions, plus optional related data. This is @@ -19,8 +20,10 @@ journalConvertAmountsToCost, journalFinalise, -- * Filtering - filterJournalPostings, filterJournalTransactions, + filterJournalPostings, + filterJournalPostingAmounts, + filterPostingAmount, -- * Querying journalAccountNames, journalAccountNamesUsed, @@ -28,6 +31,7 @@ journalAmounts, -- journalCanonicalCommodities, journalDateSpan, + journalDescriptions, journalFilePath, journalFilePaths, journalPostings, @@ -153,13 +157,19 @@ addTimeLogEntry :: TimeLogEntry -> Journal -> Journal addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : open_timelog_entries l0 } +-- | Unique transaction descriptions used in this journal. +journalDescriptions :: Journal -> [String] +journalDescriptions = nub . sort . map tdescription . jtxns + +-- | All postings from this journal's transactions, in order. journalPostings :: Journal -> [Posting] journalPostings = concatMap tpostings . jtxns --- | All account names used in this journal. +-- | Unique account names posted to in this journal. journalAccountNamesUsed :: Journal -> [AccountName] journalAccountNamesUsed = sort . accountNamesFromPostings . journalPostings +-- | Unique account names in this journal, including parent accounts containing no postings. journalAccountNames :: Journal -> [AccountName] journalAccountNames = sort . expandAccountNames . journalAccountNamesUsed @@ -228,6 +238,17 @@ where filtertransactionpostings t@Transaction{tpostings=ps} = t{tpostings=filter (q `matchesPosting`) ps} +-- Within each posting's amount, keep only the parts matching the query. +-- This can leave unbalanced transactions. +filterJournalPostingAmounts :: Query -> Journal -> Journal +filterJournalPostingAmounts q j@Journal{jtxns=ts} = j{jtxns=map filtertransactionpostings ts} + where + filtertransactionpostings t@Transaction{tpostings=ps} = t{tpostings=map (filterPostingAmount q) ps} + +-- | Filter out all parts of this posting's amount which do not match the query. +filterPostingAmount :: Query -> Posting -> Posting +filterPostingAmount q p@Posting{pamount=Mixed as} = p{pamount=Mixed $ filter (q `matchesAmount`) as} + -- | Keep only transactions matching the query expression. filterJournalTransactions :: Query -> Journal -> Journal filterJournalTransactions q j@Journal{jtxns=ts} = j{jtxns=filter (q `matchesTransaction`) ts} @@ -415,10 +436,10 @@ assertion = pbalanceassertion p Just assertedbal = assertion bal' = sum $ [bal] ++ map pamount ps - err = printf "Balance assertion failed for account %s on %s\n%safter\n %s\nexpected balance is %s, actual balance was %s." + err = printf "Balance assertion failed for account %s on %s\n%sAfter posting:\n %s\nexpected balance is %s, actual balance was %s." (paccount p) (show $ postingDate p) - (maybe "" (("In\n"++).show) $ ptransaction p) + (maybe "" (("In transaction:\n"++).show) $ ptransaction p) (show p) (showMixedAmount assertedbal) (showMixedAmount bal') @@ -524,15 +545,36 @@ journalAmounts :: Journal -> [Amount] journalAmounts = concatMap flatten . journalMixedAmounts where flatten (Mixed as) = as --- | The (fully specified) date span containing this journal's transactions, --- or DateSpan Nothing Nothing if there are none. -journalDateSpan :: Journal -> DateSpan -journalDateSpan j - | null ts = DateSpan Nothing Nothing - | otherwise = DateSpan (Just $ tdate $ head ts) (Just $ addDays 1 $ tdate $ last ts) +-- | The fully specified date span enclosing the dates (primary or secondary) +-- of all this journal's transactions and postings, or DateSpan Nothing Nothing +-- if there are none. +journalDateSpan :: Bool -> Journal -> DateSpan +journalDateSpan secondary j + | null ts = DateSpan Nothing Nothing + | otherwise = DateSpan (Just earliest) (Just $ addDays 1 latest) where - ts = sortBy (comparing tdate) $ jtxns j + earliest = minimum dates + latest = maximum dates + dates = pdates ++ tdates + tdates = map (if secondary then transactionDate2 else tdate) ts + pdates = concatMap (catMaybes . map (if secondary then (Just . postingDate2) else pdate) . tpostings) ts + ts = jtxns j +-- #ifdef TESTS +test_journalDateSpan = do + "journalDateSpan" ~: do + assertEqual "" (DateSpan (Just $ fromGregorian 2014 1 10) (Just $ fromGregorian 2014 10 11)) + (journalDateSpan True j) + where + j = nulljournal{jtxns = [nulltransaction{tdate = parsedate "2014/02/01" + ,tpostings = [posting{pdate=Just (parsedate "2014/01/10")}] + } + ,nulltransaction{tdate = parsedate "2014/09/01" + ,tpostings = [posting{pdate2=Just (parsedate "2014/10/10")}] + } + ]} +-- #endif + -- Misc helpers -- | Check if a set of hledger account/description filter patterns matches the @@ -662,6 +704,7 @@ tests_Hledger_Data_Journal = TestList $ [ + test_journalDateSpan -- "query standard account types" ~: -- do -- let j = journal1 diff --git a/Hledger/Data/Ledger.hs b/Hledger/Data/Ledger.hs --- a/Hledger/Data/Ledger.hs +++ b/Hledger/Data/Ledger.hs @@ -35,16 +35,17 @@ laccounts = [] } --- | Filter a journal's transactions with the given query, then derive a --- ledger containing the chart of accounts and balances. If the query --- includes a depth limit, that will affect the ledger's journal but not --- the account tree. +-- | Filter a journal's transactions with the given query, then derive +-- a ledger containing the chart of accounts and balances. If the +-- query includes a depth limit, that will affect the this ledger's +-- journal but not the ledger's account tree. ledgerFromJournal :: Query -> Journal -> Ledger ledgerFromJournal q j = nullledger{ljournal=j'', laccounts=as} where (q',depthq) = (filterQuery (not . queryIsDepth) q, filterQuery queryIsDepth q) - j' = filterJournalPostings q' j - as = accountsFromPostings $ journalPostings j' + j' = filterJournalPostingAmounts (filterQuery queryIsSym q) $ -- remove amount parts which the query's sym: terms would exclude + filterJournalPostings q' j + as = accountsFromPostings $ journalPostings j' j'' = filterJournalPostings depthq j' -- | List a ledger's account names. diff --git a/Hledger/Data/OutputFormat.hs b/Hledger/Data/OutputFormat.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/OutputFormat.hs @@ -0,0 +1,118 @@ +module Hledger.Data.OutputFormat ( + parseStringFormat + , formatsp + , formatValue + , OutputFormat(..) + , 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" + +parseStringFormat :: String -> Either String [OutputFormat] +parseStringFormat input = case (runParser formatsp () "(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 OutputFormat +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 OutputFormat +formatLiteral = do + s <- many1 c + return $ FormatLiteral s + where + isPrintableButNotPercentage x = isPrint x && (not $ x == '%') + c = (satisfy isPrintableButNotPercentage "printable character") + <|> try (string "%%" >> return '%') + +formatp :: GenParser Char st OutputFormat +formatp = + formatField + <|> formatLiteral + +formatsp :: GenParser Char st [OutputFormat] +formatsp = many formatp + +testFormat :: OutputFormat -> 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 -> [OutputFormat] -> Assertion +testParser s expected = case (parseStringFormat 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/Posting.hs b/Hledger/Data/Posting.hs --- a/Hledger/Data/Posting.hs +++ b/Hledger/Data/Posting.hs @@ -26,7 +26,9 @@ postingDate, postingDate2, isPostingInDateSpan, + isPostingInDateSpan', postingsDateSpan, + postingsDateSpan', -- * account name operations accountNamesFromPostings, accountNamePostingType, @@ -145,11 +147,11 @@ -- | Tags for this posting including any inherited from its parent transaction. postingAllTags :: Posting -> [Tag] -postingAllTags p = ptags p ++ maybe [] transactionAllTags (ptransaction p) +postingAllTags p = ptags p ++ maybe [] ttags (ptransaction p) --- | Tags for this transaction including any inherited from above, when that is implemented. +-- | Tags for this transaction including any from its postings. transactionAllTags :: Transaction -> [Tag] -transactionAllTags t = ttags t +transactionAllTags t = ttags t ++ concatMap ptags (tpostings t) -- Get the other postings from this posting's transaction. relatedPostings :: Posting -> [Posting] @@ -160,6 +162,11 @@ isPostingInDateSpan :: DateSpan -> Posting -> Bool isPostingInDateSpan s = spanContainsDate s . postingDate +-- --date2-sensitive version, separate for now to avoid disturbing multiBalanceReport. +isPostingInDateSpan' :: WhichDate -> DateSpan -> Posting -> Bool +isPostingInDateSpan' PrimaryDate s = spanContainsDate s . postingDate +isPostingInDateSpan' SecondaryDate s = spanContainsDate s . postingDate2 + isEmptyPosting :: Posting -> Bool isEmptyPosting = isZeroMixedAmount . pamount @@ -169,6 +176,14 @@ postingsDateSpan [] = DateSpan Nothing Nothing postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps') where ps' = sortBy (comparing postingDate) ps + +-- --date2-sensitive version, as above. +postingsDateSpan' :: WhichDate -> [Posting] -> DateSpan +postingsDateSpan' _ [] = DateSpan Nothing Nothing +postingsDateSpan' wd ps = DateSpan (Just $ postingdate $ head ps') (Just $ addDays 1 $ postingdate $ last ps') + where + ps' = sortBy (comparing postingdate) ps + postingdate = if wd == PrimaryDate then postingDate else postingDate2 -- AccountName stuff that depends on PostingType diff --git a/Hledger/Data/RawOptions.hs b/Hledger/Data/RawOptions.hs new file mode 100644 --- /dev/null +++ b/Hledger/Data/RawOptions.hs @@ -0,0 +1,68 @@ +{-| + +hledger's cmdargs modes parse command-line arguments to an +intermediate format, RawOpts (an association list), rather than a +fixed ADT like CliOpts. This allows the modes and flags to be reused +more easily by hledger commands/scripts in this and other packages. + +-} + +module Hledger.Data.RawOptions ( + RawOpts, + setopt, + setboolopt, + inRawOpts, + boolopt, + stringopt, + maybestringopt, + listofstringopt, + intopt, + maybeintopt, + optserror +) +where + +import Data.Maybe +import Safe + +import Hledger.Utils + + +-- | The result of running cmdargs: an association list of option names to string values. +type RawOpts = [(String,String)] + +setopt :: String -> String -> RawOpts -> RawOpts +setopt name val = (++ [(name, quoteIfNeeded val)]) + +setboolopt :: String -> RawOpts -> RawOpts +setboolopt name = (++ [(name,"")]) + +-- | Is the named option present ? +inRawOpts :: String -> RawOpts -> Bool +inRawOpts name = isJust . lookup name + +boolopt :: String -> RawOpts -> Bool +boolopt = inRawOpts + +maybestringopt :: String -> RawOpts -> Maybe String +maybestringopt name = maybe Nothing (Just . stripquotes) . lookup name + +stringopt :: String -> RawOpts -> String +stringopt name = fromMaybe "" . maybestringopt name + +listofstringopt :: String -> RawOpts -> [String] +listofstringopt name rawopts = [v | (k,v) <- rawopts, k==name] + +maybeintopt :: String -> RawOpts -> Maybe Int +maybeintopt name rawopts = + let ms = maybestringopt name rawopts in + case ms of Nothing -> Nothing + Just s -> Just $ readDef (optserror $ "could not parse "++name++" number: "++s) s + +intopt :: String -> RawOpts -> Int +intopt name = fromMaybe 0 . maybeintopt name + +-- | Raise an error, showing the specified message plus a hint about --help. +optserror :: String -> a +optserror = error' . (++ " (run with --help for usage)") + diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -270,7 +270,7 @@ balanceTransaction :: Maybe (Map.Map Commodity AmountStyle) -> Transaction -> Either String Transaction balanceTransaction styles t@Transaction{tpostings=ps} | length rwithoutamounts > 1 || length bvwithoutamounts > 1 - = Left $ printerr "could not balance this transaction (too many missing amounts)" + = Left $ printerr "could not balance this transaction (can't have more than one missing amount; remember to put 2 or more spaces before amounts)" | not $ isTransactionBalanced styles t''' = Left $ printerr $ nonzerobalanceerror t''' | otherwise = Right t'''' where diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -31,7 +31,7 @@ data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show) -data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord,Data,Typeable) +data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Ord,Data,Typeable) data Interval = NoInterval | Days Int | Weeks Int | Months Int | Quarters Int | Years Int @@ -169,13 +169,13 @@ type JournalUpdate = ErrorT String IO (Journal -> Journal) -- | The id of a data format understood by hledger, eg @journal@ or @csv@. -type Format = String +type StorageFormat = String -- | A hledger journal reader is a triple of format name, format-detecting -- predicate, and a parser to Journal. data Reader = Reader { -- name of the format this reader handles - rFormat :: Format + rFormat :: StorageFormat -- 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 @@ -195,7 +195,7 @@ | FieldNo Int deriving (Show, Eq) -data FormatString = +data OutputFormat = FormatLiteral String | FormatField Bool -- Left justified ? (Maybe Int) -- Min width @@ -210,7 +210,7 @@ aname :: AccountName, -- ^ this account's full name aebalance :: MixedAmount, -- ^ this account's balance, excluding subaccounts asubs :: [Account], -- ^ sub-accounts - -- anumpostings :: Int -- ^ number of postings to this account + anumpostings :: Int, -- ^ number of postings to this account -- derived from the above: aibalance :: MixedAmount, -- ^ this account's balance, including subaccounts aparent :: Maybe Account, -- ^ parent account diff --git a/Hledger/Query.hs b/Hledger/Query.hs --- a/Hledger/Query.hs +++ b/Hledger/Query.hs @@ -16,9 +16,11 @@ filterQuery, -- * accessors queryIsNull, + queryIsAcct, queryIsDepth, queryIsDate, queryIsStartDateOnly, + queryIsSym, queryStartDate, queryDateSpan, queryDepth, @@ -26,9 +28,12 @@ inAccount, inAccountQuery, -- * matching - matchesAccount, - matchesPosting, matchesTransaction, + matchesPosting, + matchesAccount, + matchesMixedAmount, + matchesAmount, + words'', -- * tests tests_Hledger_Query ) @@ -45,7 +50,7 @@ import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName -import Hledger.Data.Amount (amount, usd) +import Hledger.Data.Amount (amount, nullamt, usd) import Hledger.Data.Dates import Hledger.Data.Posting import Hledger.Data.Transaction @@ -65,7 +70,7 @@ | Date2 DateSpan -- ^ match if secondary 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 - | Amt Ordering Quantity -- ^ match if the amount's numeric quantity is less than/greater than/equal to some value + | Amt OrdPlus Quantity -- ^ match if the amount's numeric quantity is less than/greater than/equal to/unsignedly equal to some value | Sym String -- ^ match if the entire commodity symbol is matched by this regexp | Empty Bool -- ^ if true, show zero-amount postings/accounts which are usually not shown -- more of a query option than a query criteria ? @@ -165,18 +170,17 @@ words'' :: [String] -> String -> [String] words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX where - maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, quotedPattern, pattern] `sepBy` many1 spacenonewline + maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, 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 + p <- singleQuotedPattern <|> doubleQuotedPattern return $ prefix ++ stripquotes p - quotedPattern = do - p <- between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\"" - return $ stripquotes p + singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'") >>= return . stripquotes + doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") >>= return . stripquotes pattern = many (noneOf " \n\r") tests_words'' = [ @@ -204,7 +208,7 @@ ,"date" ,"edate" ,"status" - ,"sym" + ,"cur" ,"real" ,"empty" ,"depth" @@ -241,10 +245,10 @@ Right (_,span) -> Left $ Date2 span parseQueryTerm _ ('s':'t':'a':'t':'u':'s':':':s) = Left $ Status $ parseStatus s parseQueryTerm _ ('r':'e':'a':'l':':':s) = Left $ Real $ parseBool s -parseQueryTerm _ ('a':'m':'t':':':s) = Left $ Amt op q where (op, q) = parseAmountQueryTerm s +parseQueryTerm _ ('a':'m':'t':':':s) = Left $ Amt ord q where (ord, q) = parseAmountQueryTerm 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 _ ('s':'y':'m':':':s) = Left $ Sym s +parseQueryTerm _ ('c':'u':'r':':':s) = Left $ Sym s -- support cur: as an alias parseQueryTerm _ ('t':'a':'g':':':s) = Left $ Tag n v where (n,v) = parseTag s parseQueryTerm _ "" = Left $ Any parseQueryTerm d s = parseQueryTerm d $ defaultprefix++":"++s @@ -269,25 +273,43 @@ -- "amt:>10000.10" `gives` (Left $ Amt GT 10000.1) ] + +data OrdPlus = Lt | Gt | Eq | AbsLt | AbsGt | AbsEq + deriving (Show,Eq,Data,Typeable) + -- can fail -parseAmountQueryTerm :: String -> (Ordering, Quantity) -parseAmountQueryTerm s = - case s of - "" -> err - '<':s' -> (LT, readDef err s') - '=':s' -> (EQ, readDef err s') - '>':s' -> (GT, readDef err s') - s' -> (EQ, readDef err s') +parseAmountQueryTerm :: String -> (OrdPlus, Quantity) +parseAmountQueryTerm s' = + case s' of + -- feel free to do this a smarter way + "" -> err + '<':'+':s -> (Lt, readDef err s) + '>':'+':s -> (Gt, readDef err s) + '=':'+':s -> (Eq, readDef err s) + '+':s -> (Eq, readDef err s) + '<':'-':s -> (Lt, negate $ readDef err s) + '>':'-':s -> (Gt, negate $ readDef err s) + '=':'-':s -> (Eq, negate $ readDef err s) + '-':s -> (Eq, negate $ readDef err s) + '<':s -> let n = readDef err s in case n of 0 -> (Lt, 0) + _ -> (AbsLt, n) + '>':s -> let n = readDef err s in case n of 0 -> (Gt, 0) + _ -> (AbsGt, n) + '=':s -> (AbsEq, readDef err s) + s -> (AbsEq, readDef err s) where - err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a numeric quantity: " ++ s + err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a (optionally signed) numeric quantity: " ++ s' tests_parseAmountQueryTerm = [ "parseAmountQueryTerm" ~: do let s `gives` r = parseAmountQueryTerm s `is` r - "<0" `gives` (LT,0) - "=0.23" `gives` (EQ,0.23) - "0.23" `gives` (EQ,0.23) - ">10000.10" `gives` (GT,10000.1) + "<0" `gives` (Lt,0) -- special case for convenience, since AbsLt 0 would be always false + ">0" `gives` (Gt,0) -- special case for convenience and consistency with above + ">10000.10" `gives` (AbsGt,10000.1) + "=0.23" `gives` (AbsEq,0.23) + "0.23" `gives` (AbsEq,0.23) + "=+0.23" `gives` (Eq,0.23) + "-0.23" `gives` (Eq,(-0.23)) ] parseTag :: String -> (String, Maybe String) @@ -381,6 +403,7 @@ queryIsDate :: Query -> Bool queryIsDate (Date _) = True +queryIsDate (Date2 _) = True queryIsDate _ = False queryIsDesc :: Query -> Bool @@ -391,6 +414,10 @@ queryIsAcct (Acct _) = True queryIsAcct _ = False +queryIsSym :: Query -> Bool +queryIsSym (Sym _) = True +queryIsSym _ = 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 secondary date instead. @@ -517,6 +544,35 @@ assertBool "" $ not $ (Tag "a" Nothing) `matchesAccount` "a" ] +matchesMixedAmount :: Query -> MixedAmount -> Bool +matchesMixedAmount q (Mixed []) = q `matchesAmount` nullamt +matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as + +-- | Does the match expression match this (simple) amount ? +matchesAmount :: Query -> Amount -> Bool +matchesAmount (Not q) a = not $ q `matchesAmount` a +matchesAmount (Any) _ = True +matchesAmount (None) _ = False +matchesAmount (Or qs) a = any (`matchesAmount` a) qs +matchesAmount (And qs) a = all (`matchesAmount` a) qs +-- +matchesAmount (Amt ord n) a = compareAmount ord n a +matchesAmount (Sym r) a = regexMatchesCI ("^" ++ r ++ "$") $ acommodity a +-- +matchesAmount _ _ = True + +-- | Is this simple (single-amount) mixed amount's quantity less than, greater than, equal to, or unsignedly equal to this number ? +-- For multi-amount (multiple commodities, or just unsimplified) mixed amounts this is always true. + +-- | Is this amount's quantity less than, greater than, equal to, or unsignedly equal to this number ? +compareAmount :: OrdPlus -> Quantity -> Amount -> Bool +compareAmount ord q Amount{aquantity=aq} = case ord of Lt -> aq < q + Gt -> aq > q + Eq -> aq == q + AbsLt -> abs aq < abs q + AbsGt -> abs aq > abs q + AbsEq -> abs aq == abs q + -- | Does the match expression match this posting ? matchesPosting :: Query -> Posting -> Bool matchesPosting (Not q) p = not $ q `matchesPosting` p @@ -531,8 +587,9 @@ matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p 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 (Amt op n) Posting{pamount=a} = compareMixedAmount op n a +matchesPosting q@(Depth _) Posting{paccount=a} = q `matchesAccount` a +matchesPosting q@(Amt _ _) Posting{pamount=amt} = q `matchesMixedAmount` amt +-- matchesPosting q@(Amt _ _) Posting{pamount=amt} = q `matchesMixedAmount` amt -- matchesPosting (Empty v) Posting{pamount=a} = v == isZeroMixedAmount a -- matchesPosting (Empty False) Posting{pamount=a} = True -- matchesPosting (Empty True) Posting{pamount=a} = isZeroMixedAmount a @@ -542,14 +599,6 @@ matchesPosting (Tag n (Just v)) p = isJust $ lookupTagByNameAndValue (n,v) $ postingAllTags p -- matchesPosting _ _ = False --- | Is this simple mixed amount's quantity less than, equal to, or greater than this number ? --- For complext mixed amounts (with multiple commodities), this is always true. -compareMixedAmount :: Ordering -> Quantity -> MixedAmount -> Bool -compareMixedAmount op q (Mixed []) = compareMixedAmount op q (Mixed [amount]) --- compareMixedAmount op q (Mixed [a]) = strace (compare (strace $ aquantity a) (strace q)) == op -compareMixedAmount op q (Mixed [a]) = compare (aquantity a) q == op -compareMixedAmount _ _ _ = True - tests_matchesPosting = [ "matchesPosting" ~: do -- matching posting status.. @@ -613,8 +662,8 @@ 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","")]}]} + -- a tag match on a transaction also matches posting tags + assertBool "" $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]} ] lookupTagByName :: String -> [Tag] -> Maybe Tag diff --git a/Hledger/Read.hs b/Hledger/Read.hs --- a/Hledger/Read.hs +++ b/Hledger/Read.hs @@ -18,11 +18,13 @@ requireJournalFileExists, ensureJournalFileExists, -- * Parsers used elsewhere - accountname, + postingp, + accountnamep, amountp, amountp', mamountp', - code, + numberp, + codep, -- * Tests samplejournal, tests_Hledger_Read, @@ -112,7 +114,7 @@ -- - 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 :: Maybe StorageFormat -> Maybe FilePath -> Maybe FilePath -> String -> IO (Either String Journal) readJournal format rulesfile path s = -- trace (show (format, rulesfile, path)) $ tryReaders $ readersFor (format, path, s) @@ -132,19 +134,19 @@ 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 :: (Maybe StorageFormat, Maybe FilePath, String) -> [Reader] readersFor (format,path,s) = case format of - Just f -> case readerForFormat f of Just r -> [r] - Nothing -> [] + Just f -> case readerForStorageFormat f of Just r -> [r] + Nothing -> [] Nothing -> case path of Nothing -> readers Just "-" -> readers Just p -> case readersForPathAndData (p,s) of [] -> readers rs -> rs -- | Find the (first) reader which can handle the given format, if any. -readerForFormat :: Format -> Maybe Reader -readerForFormat s | null rs = Nothing +readerForStorageFormat :: StorageFormat -> Maybe Reader +readerForStorageFormat s | null rs = Nothing | otherwise = Just $ head rs where rs = filter ((s==).rFormat) readers :: [Reader] @@ -157,7 +159,7 @@ -- 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 :: Maybe StorageFormat -> Maybe FilePath -> FilePath -> IO (Either String Journal) readJournalFile format rulesfile "-" = do hSetNewlineMode stdin universalNewlineMode getContents >>= readJournal format rulesfile (Just "(stdin)") @@ -173,7 +175,7 @@ exists <- doesFileExist f when (not exists) $ do hPrintf stderr "The hledger journal file \"%s\" was not found.\n" f - hPrintf stderr "Please create it first, eg with hledger add or a text editor.\n" + hPrintf stderr "Please create it first, eg with \"hledger add\" or a text editor.\n" hPrintf stderr "Or, specify an existing journal file with -f or LEDGER_FILE.\n" exitFailure diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs --- a/Hledger/Read/JournalReader.hs +++ b/Hledger/Read/JournalReader.hs @@ -26,13 +26,16 @@ directive, defaultyeardirective, historicalpricedirective, - datetime, - code, - accountname, + datetimep, + codep, + accountnamep, + postingp, amountp, amountp', mamountp', - emptyline + numberp, + emptyorcommentlinep, + followingcommentp #ifdef TESTS -- * Tests -- disabled by default, HTF not available on windows @@ -158,7 +161,7 @@ , liftM (return . addModifierTransaction) modifiertransaction , liftM (return . addPeriodicTransaction) periodictransaction , liftM (return . addHistoricalPrice) historicalpricedirective - , emptyline >> return (return id) + , emptyorcommentlinep >> return (return id) ] "journal transaction or directive" -- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives @@ -206,7 +209,7 @@ accountdirective = do string "account" many1 spacenonewline - parent <- accountname + parent <- accountnamep newline pushParentAccount parent return $ return id @@ -271,7 +274,7 @@ historicalpricedirective = do char 'P' "historical price" many spacenonewline - date <- try (do {LocalTime d _ <- datetime; return d}) <|> date -- a time is ignored + date <- try (do {LocalTime d _ <- datetimep; return d}) <|> date -- a time is ignored many1 spacenonewline symbol <- commoditysymbol many spacenonewline @@ -322,9 +325,9 @@ date <- date "transaction" edate <- optionMaybe (secondarydate date) "secondary date" status <- status "cleared flag" - code <- code "transaction code" + code <- codep "transaction code" description <- descriptionp >>= return . strip - comment <- try followingcomment <|> (newline >> return "") + comment <- try followingcommentp <|> (newline >> return "") let tags = tagsInComment comment postings <- postings return $ txnTieKnot $ Transaction date edate status code description comment tags postings "" @@ -442,8 +445,8 @@ -- 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. -datetime :: GenParser Char JournalContext LocalTime -datetime = do +datetimep :: GenParser Char JournalContext LocalTime +datetimep = do day <- date many1 spacenonewline h <- many1 digit @@ -486,8 +489,8 @@ status :: GenParser Char JournalContext Bool status = try (do { many spacenonewline; (char '*' <|> char '!') "status"; return True } ) <|> return False -code :: GenParser Char JournalContext String -code = try (do { many1 spacenonewline; char '(' "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" +codep :: GenParser Char JournalContext String +codep = try (do { many1 spacenonewline; char '(' "codep"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" -- Parse the following whitespace-beginning lines as postings, posting tags, and/or comments. postings :: GenParser Char JournalContext [Posting] @@ -512,7 +515,7 @@ _ <- fixedlotprice many spacenonewline ctx <- getState - comment <- try followingcomment <|> (newline >> return "") + comment <- try followingcommentp <|> (newline >> return "") let tags = tagsInComment comment -- oh boy d <- maybe (return Nothing) (either (fail.show) (return.Just)) (parseWithCtx ctx date `fmap` dateValueFromTags tags) @@ -569,7 +572,7 @@ -- | 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 <- accountname + a <- accountnamep prefix <- getParentAccount let prefixed = prefix `joinAccountNames` a aliases <- getAccountAliases @@ -579,12 +582,12 @@ -- 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. -accountname :: GenParser Char st AccountName -accountname = do +accountnamep :: GenParser Char st AccountName +accountnamep = do a <- many1 (nonspace <|> singlespace) let a' = striptrailingspace a when (accountNameFromComponents (accountNameComponents a') /= a') - (fail $ "accountname seems ill-formed: "++a') + (fail $ "account name seems ill-formed: "++a') return a' where singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}) @@ -646,21 +649,27 @@ mamountp' :: String -> MixedAmount mamountp' = mixed . amountp' +signp :: GenParser Char JournalContext String +signp = do + sign <- optionMaybe $ oneOf "+-" + return $ case sign of Just '-' -> "-" + _ -> "" + leftsymbolamount :: GenParser Char JournalContext Amount leftsymbolamount = do - sign <- optionMaybe $ string "-" - let applysign = if isJust sign then negate else id + sign <- signp c <- commoditysymbol sp <- many spacenonewline - (q,prec,dec,sep,seppos) <- number + (q,prec,dec,sep,seppos) <- numberp let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos} p <- priceamount + let applysign = if sign=="-" then negate else id return $ applysign $ Amount c q p s "left-symbol amount" rightsymbolamount :: GenParser Char JournalContext Amount rightsymbolamount = do - (q,prec,dec,sep,seppos) <- number + (q,prec,dec,sep,seppos) <- numberp sp <- many spacenonewline c <- commoditysymbol p <- priceamount @@ -670,12 +679,12 @@ nosymbolamount :: GenParser Char JournalContext Amount nosymbolamount = do - (q,prec,dec,sep,seppos) <- number + (q,prec,dec,sep,seppos) <- numberp p <- priceamount defcs <- getCommodityAndStyle let (c,s) = case defcs of - Just (c',s') -> (c',s') - Nothing -> ("", amountstyle{asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos}) + Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) prec}) + Nothing -> ("", amountstyle{asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos}) return $ Amount c q p s "no-symbol amount" @@ -743,25 +752,26 @@ -- and separator characters (defaulting to . and ,), and the positions of -- separators (counting leftward from the decimal point, the last is -- assumed to repeat). -number :: GenParser Char JournalContext (Quantity, Int, Char, Char, [Int]) -number = do - sign <- optionMaybe $ string "-" +numberp :: GenParser Char JournalContext (Quantity, Int, Char, Char, [Int]) +numberp = do + sign <- signp parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.'] let numeric = isNumber . headDef '_' - (_, puncparts) = partition numeric parts + (numparts, puncparts) = partition numeric parts (ok,decimalpoint',separator') = - case puncparts of - [] -> (True, Nothing, Nothing) -- no punctuation chars - [d:""] -> (True, Just d, Nothing) -- just one punctuation char, assume it's a decimal point - [_] -> (False, Nothing, Nothing) -- adjacent punctuation chars, not ok - _:_:_ -> let (s:ss, d) = (init puncparts, last puncparts) -- two or more punctuation chars - in if (any ((/=1).length) puncparts -- adjacent punctuation chars, not ok - || any (s/=) ss -- separator chars differ, not ok - || head parts == s) -- number begins with a separator char, not ok - then (False, Nothing, Nothing) - else if s == d - then (True, Nothing, Just $ head s) -- just one kind of punctuation, assume separator chars - else (True, Just $ head d, Just $ head s) -- separators and a decimal point + case (numparts,puncparts) of + ([],_) -> (False, Nothing, Nothing) -- no digits + (_,[]) -> (True, Nothing, Nothing) -- no punctuation chars + (_,[d:""]) -> (True, Just d, Nothing) -- just one punctuation char, assume it's a decimal point + (_,[_]) -> (False, Nothing, Nothing) -- adjacent punctuation chars, not ok + (_,_:_:_) -> let (s:ss, d) = (init puncparts, last puncparts) -- two or more punctuation chars + in if (any ((/=1).length) puncparts -- adjacent punctuation chars, not ok + || any (s/=) ss -- separator chars differ, not ok + || head parts == s) -- number begins with a separator char, not ok + then (False, Nothing, Nothing) + else if s == d + then (True, Nothing, Just $ head s) -- just one kind of punctuation, assume separator chars + else (True, Just $ head d, Just $ head s) -- separators and a decimal point when (not ok) (fail $ "number seems ill-formed: "++concat parts) let (intparts',fracparts') = span ((/= decimalpoint') . Just . head) parts (intparts, fracpart) = (filter numeric intparts', filter numeric fracparts') @@ -771,8 +781,7 @@ precision = length frac int' = if null int then "0" else int frac' = if null frac then "0" else frac - sign' = fromMaybe "" sign - quantity = read $ sign'++int'++"."++frac' -- this read should never fail + quantity = read $ sign++int'++"."++frac' -- this read should never fail (decimalpoint, separator) = case (decimalpoint', separator') of (Just d, Just s) -> (d,s) (Just '.',Nothing) -> ('.',',') (Just ',',Nothing) -> (',','.') @@ -780,12 +789,12 @@ (Nothing, Just ',') -> ('.',',') _ -> ('.',',') return (quantity,precision,decimalpoint,separator,separatorpositions) - "number" + "numberp" #ifdef TESTS -test_number = do - let s `is` n = assertParseEqual' (parseWithCtx nullctx number s) n - assertFails = assertBool . isLeft . parseWithCtx nullctx number +test_numberp = do + let s `is` n = assertParseEqual' (parseWithCtx nullctx numberp s) n + assertFails = assertBool . isLeft . parseWithCtx nullctx numberp assertFails "" "0" `is` (0, 0, '.', ',', []) "1" `is` (1, 0, '.', ',', []) @@ -808,23 +817,28 @@ -- comment parsers -emptyline :: GenParser Char JournalContext () -emptyline = do many spacenonewline - optional $ (char ';' "comment") >> many (noneOf "\n") - newline - return () +emptyorcommentlinep :: GenParser Char JournalContext () +emptyorcommentlinep = do + many spacenonewline >> (comment <|> (many spacenonewline >> newline >> return "")) + return () -followingcomment :: GenParser Char JournalContext String -followingcomment = - -- ptrace "followingcomment" - do samelinecomment <- many spacenonewline >> (try commentline <|> (newline >> return "")) - newlinecomments <- many (try (many1 spacenonewline >> commentline)) +followingcommentp :: GenParser Char JournalContext String +followingcommentp = + -- ptrace "followingcommentp" + do samelinecomment <- many spacenonewline >> (try semicoloncomment <|> (newline >> return "")) + newlinecomments <- many (try (many1 spacenonewline >> semicoloncomment)) return $ unlines $ samelinecomment:newlinecomments -commentline :: GenParser Char JournalContext String -commentline = do - -- ptrace "commentline" - char ';' +comment :: GenParser Char JournalContext String +comment = commentStartingWith "#;" + +semicoloncomment :: GenParser Char JournalContext String +semicoloncomment = commentStartingWith ";" + +commentStartingWith :: String -> GenParser Char JournalContext String +commentStartingWith cs = do + -- ptrace "commentStartingWith" + oneOf cs many spacenonewline l <- anyChar `manyTill` eolof optional newline @@ -892,12 +906,12 @@ {- old hunit tests test_Hledger_Read_JournalReader = TestList $ concat [ - test_number, + test_numberp, test_amountp, test_spaceandamountormissing, test_tagcomment, test_inlinecomment, - test_commentlines, + test_comments, test_ledgerDateSyntaxToTags, test_postingp, test_transaction, @@ -913,18 +927,18 @@ 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") + ,"comment" ~: do + assertParse (parseWithCtx nullctx comment "; some comment \n") + assertParse (parseWithCtx nullctx comment " \t; x\n") + assertParse (parseWithCtx nullctx comment "#x") ,"date" ~: do assertParse (parseWithCtx nullctx date "2011/1/1") assertParseFailure (parseWithCtx nullctx date "1/1") assertParse (parseWithCtx nullctx{ctxYear=Just 2011} date "1/1") - ,"datetime" ~: do - let p = do {t <- datetime; eof; return t} + ,"datetimep" ~: do + let p = do {t <- datetimep; eof; return t} bad = assertParseFailure . parseWithCtx nullctx p good = assertParse . parseWithCtx nullctx p bad "2011/1/1" @@ -962,11 +976,11 @@ assertParse (parseWithCtx nullctx endtagdirective "end tag \n") assertParse (parseWithCtx nullctx endtagdirective "pop \n") - ,"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:") + ,"accountnamep" ~: do + assertBool "accountnamep parses a normal account name" (isRight $ parsewith accountnamep "a:b:c") + assertBool "accountnamep rejects an empty inner component" (isLeft $ parsewith accountnamep "a::c") + assertBool "accountnamep rejects an empty leading component" (isLeft $ parsewith accountnamep ":b:c") + assertBool "accountnamep rejects an empty trailing component" (isLeft $ parsewith accountnamep "a:b:") ,"leftsymbolamount" ~: do assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1") (usd 1 `withPrecision` 0) diff --git a/Hledger/Read/TimelogReader.hs b/Hledger/Read/TimelogReader.hs --- a/Hledger/Read/TimelogReader.hs +++ b/Hledger/Read/TimelogReader.hs @@ -56,7 +56,7 @@ import Hledger.Data -- XXX too much reuse ? import Hledger.Read.JournalReader ( - directive, historicalpricedirective, defaultyeardirective, emptyline, datetime, + directive, historicalpricedirective, defaultyeardirective, emptyorcommentlinep, datetimep, parseJournalWith, getParentAccount ) import Hledger.Utils @@ -91,7 +91,7 @@ timelogItem = choice [ directive , liftM (return . addHistoricalPrice) historicalpricedirective , defaultyeardirective - , emptyline >> return (return id) + , emptyorcommentlinep >> return (return id) , liftM (return . addTimeLogEntry) timelogentry ] "timelog entry, or default year or historical price directive" @@ -100,7 +100,7 @@ timelogentry = do code <- oneOf "bhioO" many1 spacenonewline - datetime <- datetime + datetime <- datetimep comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline) return $ TimeLogEntry (read [code]) datetime (maybe "" rstrip comment) diff --git a/Hledger/Reports.hs b/Hledger/Reports.hs --- a/Hledger/Reports.hs +++ b/Hledger/Reports.hs @@ -9,1289 +9,35 @@ -} module Hledger.Reports ( - -- * Report options - -- | - ReportOpts(..), - BalanceType(..), - DisplayExp, - FormatStr, - defreportopts, - dateSpanFromOpts, - intervalFromOpts, - clearedValueFromOpts, - whichDateFromOpts, - journalSelectingAmountFromOpts, - queryFromOpts, - queryOptsFromOpts, - reportSpans, - -- * Entries report - -- | - EntriesReport, - EntriesReportItem, - entriesReport, - -- * Postings report - -- | - PostingsReport, - PostingsReportItem, - postingsReport, - mkpostingsReportItem, -- XXX for showPostingWithBalanceForVty in Hledger.Cli.Register - -- * Transactions report - -- | - TransactionsReport, - TransactionsReportItem, - triDate, - triBalance, - triSimpleBalance, - transactionsReportByCommodity, - journalTransactionsReport, - accountTransactionsReport, - - -- * Balance reports - {-| - These are used for the various modes of the balance command - (see "Hledger.Cli.Balance"). - -} - BalanceReport, - BalanceReportItem, - balanceReport, - MultiBalanceReport(..), - MultiBalanceReportItem, - RenderableAccountName, - periodBalanceReport, - cumulativeOrHistoricalBalanceReport, - - -- * Other reports - -- | - accountBalanceHistory, - - -- * Tests - tests_Hledger_Reports -) -where - -import Control.Monad -import Data.List -import Data.Maybe --- import qualified Data.Map as M -import Data.Ord -import Data.Time.Calendar --- import Data.Tree -import Safe (headMay, lastMay) -import System.Console.CmdArgs -- for defaults support -import Test.HUnit -import Text.ParserCombinators.Parsec -import Text.Printf - -import Hledger.Data -import Hledger.Read (mamountp') -import Hledger.Query -import Hledger.Utils - ------------------------------------------------------------------------------- --- report options handling - --- | 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 - ,period_ :: Maybe (Interval,DateSpan) - ,cleared_ :: Bool - ,uncleared_ :: Bool - ,cost_ :: Bool - ,depth_ :: Maybe Int - ,display_ :: Maybe DisplayExp - ,date2_ :: Bool - ,empty_ :: Bool - ,no_elide_ :: Bool - ,real_ :: Bool - ,balancetype_ :: BalanceType -- for balance command - ,flat_ :: Bool -- for balance command - ,drop_ :: Int -- " - ,no_total_ :: Bool -- " - ,daily_ :: Bool - ,weekly_ :: Bool - ,monthly_ :: Bool - ,quarterly_ :: Bool - ,yearly_ :: Bool - ,format_ :: Maybe FormatStr - ,related_ :: Bool - ,average_ :: Bool - ,query_ :: String -- all arguments, as a string - } deriving (Show, Data, Typeable) - -type DisplayExp = String -type FormatStr = String - --- | Which balance is being shown in a multi-column balance report. -data BalanceType = PeriodBalance -- ^ The change of balance in each period. - | CumulativeBalance -- ^ The accumulated balance at each period's end, starting from zero at the report start date. - | HistoricalBalance -- ^ The historical balance at each period's end, starting from the account balances at the report start date. - deriving (Eq,Show,Data,Typeable) -instance Default BalanceType where def = PeriodBalance - -defreportopts = ReportOpts - def - def - def - def - def - def - def - def - def - def - def - def - def - def - def - def - def - def - def - def - def - def - def - def - def - -instance Default ReportOpts where def = defreportopts - --- | Figure out the date span we should report on, based on any --- begin/end/period options provided. A period option will cause begin and --- end options to be ignored. -dateSpanFromOpts :: Day -> ReportOpts -> DateSpan -dateSpanFromOpts _ ReportOpts{..} = - case period_ of Just (_,span) -> span - Nothing -> DateSpan begin_ end_ - --- | Figure out the reporting interval, if any, specified by the options. --- --period overrides --daily overrides --weekly overrides --monthly etc. -intervalFromOpts :: ReportOpts -> Interval -intervalFromOpts ReportOpts{..} = - case period_ of - Just (interval,_) -> interval - Nothing -> i - where i | daily_ = Days 1 - | weekly_ = Weeks 1 - | monthly_ = Months 1 - | quarterly_ = Quarters 1 - | yearly_ = Years 1 - | otherwise = NoInterval - --- | Get a maybe boolean representing the last cleared/uncleared option if any. -clearedValueFromOpts :: ReportOpts -> Maybe Bool -clearedValueFromOpts ReportOpts{..} | cleared_ = Just True - | uncleared_ = Just False - | otherwise = Nothing - --- depthFromOpts :: ReportOpts -> Int --- depthFromOpts opts = min (fromMaybe 99999 $ depth_ opts) (queryDepth $ queryFromOpts nulldate opts) - --- | Report which date we will report on based on --date2. -whichDateFromOpts :: ReportOpts -> WhichDate -whichDateFromOpts ReportOpts{..} = if date2_ then SecondaryDate else PrimaryDate - --- | Select the Transaction date accessor based on --date2. -transactionDateFn :: ReportOpts -> (Transaction -> Day) -transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate - --- | Select the Posting date accessor based on --date2. -postingDateFn :: ReportOpts -> (Posting -> Day) -postingDateFn ReportOpts{..} = if date2_ then postingDate2 else postingDate - - --- | Convert this journal's postings' amounts to the cost basis amounts if --- specified by options. -journalSelectingAmountFromOpts :: ReportOpts -> Journal -> Journal -journalSelectingAmountFromOpts opts - | cost_ opts = journalConvertAmountsToCost - | otherwise = id - --- | Convert report options and arguments to a query. -queryFromOpts :: Day -> ReportOpts -> Query -queryFromOpts d opts@ReportOpts{..} = simplifyQuery $ And $ [flagsq, argsq] - where - flagsq = And $ - [(if date2_ then Date2 else 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_ - -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 "" (Date2 $ 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 --- originally entered in the journal (mostly). This is used by eg --- hledger's print command and hledger-web's journal entries view. -type EntriesReport = [EntriesReportItem] -type EntriesReportItem = Transaction - --- | Select transactions for an entries report. -entriesReport :: ReportOpts -> Query -> Journal -> EntriesReport -entriesReport opts q j = - sortBy (comparing date) $ filter (q `matchesTransaction`) ts - where - 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 --- for the total field, and a little extra transaction info to help with rendering. --- This is used eg for the register command. -type PostingsReport = (String -- label for the running balance column XXX remove - ,[PostingsReportItem] -- line items, one per posting - ) -type PostingsReportItem = (Maybe Day -- posting date, if this is the first posting in a transaction or if it's different from the previous posting's date - ,Maybe String -- transaction description, if this is the first posting in a transaction - ,Posting -- the posting, possibly with account name depth-clipped - ,MixedAmount -- the running total after this posting (or with --average, the running average) - ) - --- | 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 -> Query -> Journal -> PostingsReport -postingsReport opts q j = -- trace ("q: "++show q++"\nq': "++show q') $ - (totallabel, postingsReportItems ps nullposting wd depth startbal runningcalcfn 1) - where - ps | interval == NoInterval = displayableps - | otherwise = summarisePostingsByInterval interval depth empty reportspan displayableps - j' = journalSelectingAmountFromOpts opts j - wd = whichDateFromOpts opts - -- delay depth filtering until the end - (depth, q') = (queryDepth q, filterQuery (not . queryIsDepth) q) - (precedingps, displayableps, _) = dbg "ps4" $ postingsMatchingDisplayExpr displayexpr opts - $ dbg "ps3" $ (if related_ opts then concatMap relatedPostings else id) - $ dbg "ps2" $ filter (q' `matchesPosting`) - $ dbg "ps1" $ journalPostings j' - -- enable to debug just this function - -- dbg :: Show a => String -> a -> a - -- dbg = lstrace - - 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 = queryDateSpan secondarydate q - secondarydate = whichDateFromOpts opts == SecondaryDate - displayspan = postingsDateSpan ps - where (_,ps,_) = postingsMatchingDisplayExpr displayexpr opts $ journalPostings j' - matchedspan = postingsDateSpan displayableps - reportspan | empty = requestedspan `orDatesFrom` journalspan - | otherwise = requestedspan `spanIntersect` matchedspan - startbal = sumPostings precedingps - runningcalcfn | average_ opts = \i avg amt -> avg + (amt - avg) `divideMixedAmount` (fromIntegral i) - | otherwise = \_ bal amt -> bal + amt - -totallabel = "Total" -balancelabel = "Balance" - --- | Generate postings report line items. -postingsReportItems :: [Posting] -> Posting -> WhichDate -> Int -> MixedAmount -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) -> Int -> [PostingsReportItem] -postingsReportItems [] _ _ _ _ _ _ = [] -postingsReportItems (p:ps) pprev wd d b runningcalcfn itemnum = i:(postingsReportItems ps p wd d b' runningcalcfn (itemnum+1)) - where - i = mkpostingsReportItem showdate showdesc wd p' b' - showdate = isfirstintxn || isdifferentdate - showdesc = isfirstintxn - isfirstintxn = ptransaction p /= ptransaction pprev - isdifferentdate = case wd of PrimaryDate -> postingDate p /= postingDate pprev - SecondaryDate -> postingDate2 p /= postingDate2 pprev - p' = p{paccount=clipAccountName d $ paccount p} - b' = runningcalcfn itemnum b (pamount p) - --- | Generate one postings report line item, containing the posting, --- the current running balance, and optionally the posting date and/or --- the transaction description. -mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Posting -> MixedAmount -> PostingsReportItem -mkpostingsReportItem showdate showdesc wd p b = (if showdate then Just date else Nothing, if showdesc then Just desc else Nothing, p, b) - where - date = case wd of PrimaryDate -> postingDate p - SecondaryDate -> postingDate2 p - desc = maybe "" tdescription $ ptransaction p - --- | Date-sort and split a list of postings into three spans - postings matched --- by the given display expression, and the preceding and following postings. --- XXX always sorts by primary date, should sort by secondary date if expression is about that -postingsMatchingDisplayExpr :: Maybe String -> ReportOpts -> [Posting] -> ([Posting],[Posting],[Posting]) -postingsMatchingDisplayExpr d opts ps = (before, matched, after) - where - sorted = sortBy (comparing (postingDateFn opts)) ps - (before, rest) = break (displayExprMatches d) sorted - (matched, after) = span (displayExprMatches d) rest - --- | Does this display expression allow this posting to be displayed ? --- Raises an error if the display expression can't be parsed. -displayExprMatches :: Maybe String -> Posting -> Bool -displayExprMatches Nothing _ = True -displayExprMatches (Just d) p = (fromparse $ parsewith datedisplayexpr d) p - --- | Parse a hledger display expression, which is a simple date test like --- "d>[DATE]" or "d<=[DATE]", and return a "Posting"-matching predicate. -datedisplayexpr :: GenParser Char st (Posting -> Bool) -datedisplayexpr = do - char 'd' - op <- compareop - char '[' - (y,m,d) <- smartdate - char ']' - let date = parsedate $ printf "%04s/%02s/%02s" y m d - test op = return $ (`op` date) . postingDate - case op of - "<" -> test (<) - "<=" -> test (<=) - "=" -> test (==) - "==" -> test (==) - ">=" -> test (>=) - ">" -> test (>) - _ -> mzero - where - compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] - --- -- | Clip the account names to the specified depth in a list of postings. --- depthClipPostings :: Maybe Int -> [Posting] -> [Posting] --- depthClipPostings depth = map (depthClipPosting depth) - --- -- | Clip a posting's account name to the specified depth. --- depthClipPosting :: Maybe Int -> Posting -> Posting --- depthClipPosting Nothing p = p --- depthClipPosting (Just d) p@Posting{paccount=a} = p{paccount=clipAccountName d a} - --- XXX confusing, refactor - --- | Convert a list of postings into summary postings. Summary postings --- are one per account per interval and aggregated to the specified depth --- if any. -summarisePostingsByInterval :: Interval -> 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 --- as a summary for this interval. --- --- As usual with date spans the end date is exclusive, but for display --- purposes we show the previous day as end date, like ledger. --- --- When a depth argument is present, postings to accounts of greater --- depth are aggregated where possible. --- --- The showempty flag includes spans with no postings and also postings --- with 0 amount. -summarisePostingsInDateSpan :: DateSpan -> Int -> Bool -> [Posting] -> [Posting] -summarisePostingsInDateSpan (DateSpan b e) depth showempty ps - | null ps && (isNothing b || isNothing e) = [] - | null ps && showempty = [summaryp] - | otherwise = summaryps' - where - summaryp = summaryPosting b' ("- "++ showDate (addDays (-1) e')) - b' = fromMaybe (maybe nulldate postingDate $ headMay ps) b - e' = fromMaybe (maybe (addDays 1 nulldate) postingDate $ lastMay ps) e - summaryPosting date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}} - summaryps' = (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps - summaryps = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames] - clippedanames = nub $ map (clipAccountName depth) anames - anames = sort $ nub $ map paccount ps - -- aggregate balances by account, like ledgerFromJournal, then do depth-clipping - accts = accountsFromPostings ps - balance a = maybe nullmixedamt bal $ lookupAccount a accts - where - bal = if isclipped a then aibalance else aebalance - isclipped a = accountNameLevel a >= depth - -------------------------------------------------------------------------------- - --- | A transactions report includes a list of transactions --- (posting-filtered and unfiltered variants), a running balance, and some --- other information helpful for rendering a register view (a flag --- indicating multiple other accounts and a display string describing --- them) with or without a notion of current account(s). --- Two kinds of report use this data structure, see journalTransactionsReport --- and accountTransactionsReport below for detais. -type TransactionsReport = (String -- label for the balance column, eg "balance" or "total" - ,[TransactionsReportItem] -- line items, one per transaction - ) -type TransactionsReportItem = (Transaction -- the corresponding transaction - ,Transaction -- the transaction with postings to the current account(s) removed - ,Bool -- is this a split, ie more than one other account posting - ,String -- a display string describing the other account(s), if any - ,MixedAmount -- the amount posted to the current account(s) (or total amount posted) - ,MixedAmount -- the running balance for the current account(s) after this transaction - ) - -triDate (t,_,_,_,_,_) = tdate t -triAmount (_,_,_,_,a,_) = a -triBalance (_,_,_,_,_,a) = a -triSimpleBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0" - (Amount{aquantity=q}):_ -> show q - --- Split a transactions report whose items may involve several commodities, --- into one or more single-commodity transactions reports. -transactionsReportByCommodity :: TransactionsReport -> [TransactionsReport] -transactionsReportByCommodity tr = - [filterTransactionsReportByCommodity c tr | c <- transactionsReportCommodities tr] - where - transactionsReportCommodities (_,items) = - nub $ sort $ map acommodity $ concatMap (amounts . triAmount) items - --- Remove transaction report items and item amount (and running --- balance amount) components that don't involve the specified --- commodity. Other item fields such as the transaction are left unchanged. -filterTransactionsReportByCommodity :: Commodity -> TransactionsReport -> TransactionsReport -filterTransactionsReportByCommodity c (label,items) = - (label, fixTransactionsReportItemBalances $ concat [filterTransactionsReportItemByCommodity c i | i <- items]) - where - filterTransactionsReportItemByCommodity c (t,t2,s,o,a,bal) - | c `elem` cs = [item'] - | otherwise = [] - where - cs = map acommodity $ amounts a - item' = (t,t2,s,o,a',bal) - a' = filterMixedAmountByCommodity c a - - fixTransactionsReportItemBalances [] = [] - fixTransactionsReportItemBalances [i] = [i] - fixTransactionsReportItemBalances items = reverse $ i:(go startbal is) - where - i:is = reverse items - startbal = filterMixedAmountByCommodity c $ triBalance i - go _ [] = [] - go bal ((t,t2,s,o,amt,_):is) = (t,t2,s,o,amt,bal'):go bal' is - where bal' = bal + amt - --- | Filter out all but the specified commodity from this amount. -filterMixedAmountByCommodity :: Commodity -> MixedAmount -> MixedAmount -filterMixedAmountByCommodity c (Mixed as) = Mixed $ filter ((==c). acommodity) as - --- | Select transactions from the whole journal. This is similar to a --- "postingsReport" except with transaction-based report items which --- are ordered most recent first. This is used by eg hledger-web's journal view. -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 - items = reverse $ accountTransactionsReportItems m Nothing nullmixedamt id ts' - -- XXX items' first element should be the full transaction with all postings - -------------------------------------------------------------------------------- - --- | Select transactions within one or more current accounts, and make a --- transactions report relative to those account(s). This means: --- --- 1. it shows transactions from the point of view of the current account(s). --- The transaction amount is the amount posted to the current account(s). --- The other accounts' names are provided. --- --- 2. With no transaction filtering in effect other than a start date, it --- shows the accurate historical running balance for the current account(s). --- Otherwise it shows a running total starting at 0. --- --- This is used by eg hledger-web's account register view. Currently, --- reporting intervals are not supported, and report items are most --- recent first. -accountTransactionsReport :: ReportOpts -> Journal -> Query -> Query -> TransactionsReport -accountTransactionsReport opts j m thisacctquery = (label, items) - where - -- transactions affecting this account, in date order - ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctquery) $ jtxns $ - 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) | queryIsNull m = (nullmixedamt, balancelabel) - | queryIsStartDateOnly (date2_ opts) m = (sumPostings priorps, balancelabel) - | otherwise = (nullmixedamt, totallabel) - where - priorps = -- ltrace "priorps" $ - filter (matchesPosting - (-- ltrace "priormatcher" $ - And [thisacctquery, tostartdatequery])) - $ transactionsPostings ts - tostartdatequery = Date (DateSpan Nothing startdate) - startdate = queryStartDate (date2_ 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 queries, starting balance, --- sign-setting function and balance-summing function. -accountTransactionsReportItems :: Query -> Maybe Query -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem] -accountTransactionsReportItems _ _ _ _ [] = [] -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 query t - (psthisacct,psotheracct) = case thisacctquery of Just m -> partition (matchesPosting m) psmatched - Nothing -> ([],psmatched) - numotheraccts = length $ nub $ map paccount psotheracct - amt = negate $ sum $ map pamount psthisacct - acct | isNothing thisacctquery = summarisePostings psmatched -- journal register - | numotheraccts == 0 = "transfer between " ++ summarisePostingAccounts psthisacct - | otherwise = prefix ++ summarisePostingAccounts psotheracct - where prefix = maybe "" (\b -> if b then "from " else "to ") $ isNegativeMixedAmount amt - (i,bal') = case psmatched of - [] -> (Nothing,bal) - _ -> (Just (t, tmatched, numotheraccts > 1, acct, a, b), b) - where - a = signfn amt - b = bal + a - is = accountTransactionsReportItems query thisacctquery bal' signfn ts - --- | Generate a short readable summary of some postings, like --- "from (negatives) to (positives)". -summarisePostings :: [Posting] -> String -summarisePostings ps = - case (summarisePostingAccounts froms, summarisePostingAccounts tos) of - ("",t) -> "to "++t - (f,"") -> "from "++f - (f,t) -> "from "++f++" to "++t - where - (froms,tos) = partition (fromMaybe False . isNegativeMixedAmount . pamount) ps - --- | Generate a simplified summary of some postings' accounts. -summarisePostingAccounts :: [Posting] -> String -summarisePostingAccounts = intercalate ", " . map accountLeafName . nub . map paccount - -filterTransactionPostings :: Query -> Transaction -> Transaction -filterTransactionPostings m t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps} - -------------------------------------------------------------------------------- - --- | A list of account names plus rendering info, along with their --- balances as of the end of the reporting period, and the grand --- total. Used for the balance command's single-column mode. -type BalanceReport = ([BalanceReportItem] -- line items, one per account - ,MixedAmount -- total balance of all accounts - ) --- | * Full account name, --- --- * short account name for display (the leaf name, prefixed by any boring parents immediately above), --- --- * how many steps to indent this account (the 0-based account depth excluding boring parents, or 0 with --flat), --- --- * account balance (including subaccounts (XXX unless --flat)). -type BalanceReportItem = (AccountName - ,AccountName - ,Int - ,MixedAmount) - --- | Select accounts, and get their balances at the end of the selected --- period, and misc. display information, for an accounts report. -balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport -balanceReport opts q j = (items, total) - where - l = ledgerFromJournal q $ journalSelectingAmountFromOpts opts j - accts = clipAccounts (queryDepth q) $ ledgerRootAccount l - accts' - | flat_ opts = filterzeros $ tail $ flattenAccounts accts - | otherwise = filter (not.aboring) $ tail $ flattenAccounts $ markboring $ prunezeros accts - where - filterzeros | empty_ opts = id - | otherwise = filter (not . isZeroMixedAmount . aebalance) - prunezeros | empty_ opts = id - | otherwise = fromMaybe nullacct . pruneAccounts (isZeroMixedAmount.aibalance) - markboring | no_elide_ opts = id - | otherwise = markBoringParentAccounts - items = map (balanceReportItem opts) accts' - total = sum [amt | (a,_,indent,amt) <- items, if flat_ opts then accountNameLevel a == 1 else indent == 0] - -- XXX check account level == 1 is valid when top-level accounts excluded - --- | In an account tree with zero-balance leaves removed, mark the --- elidable parent accounts (those with one subaccount and no balance --- of their own). -markBoringParentAccounts :: Account -> Account -markBoringParentAccounts = tieAccountParents . mapAccounts mark - where - mark a | length (asubs a) == 1 && isZeroMixedAmount (aebalance a) = a{aboring=True} - | otherwise = a - -balanceReportItem :: ReportOpts -> Account -> BalanceReportItem -balanceReportItem opts a@Account{aname=name, aibalance=ibal} - | flat_ opts = (name, name, 0, ibal) - | otherwise = (name, elidedname, indent, ibal) - where - elidedname = accountNameFromComponents (adjacentboringparentnames ++ [accountLeafName name]) - adjacentboringparentnames = reverse $ map (accountLeafName.aname) $ takeWhile aboring $ parents - indent = length $ filter (not.aboring) parents - parents = init $ parentAccounts a - - -------------------------------------------------------------------------------- - --- | A multi(column) balance report is a list of accounts, each with a list of --- balances corresponding to the report's column periods. The balances' meaning depends --- on the type of balance report (see 'BalanceType' and "Hledger.Cli.Balance"). --- Also included are the overall total for each period, the date span for each period, --- and some additional rendering info for the accounts. --- --- * The date span for each report column, --- --- * line items (one per account), --- --- * the final total for each report column. -newtype MultiBalanceReport = MultiBalanceReport - ([DateSpan] - ,[MultiBalanceReportItem] - ,[MixedAmount] - ) - --- | * The account name with rendering hints, --- --- * the account's balance (per-period balance, cumulative ending --- balance, or historical ending balance) in each of the report's --- periods. -type MultiBalanceReportItem = - (RenderableAccountName - ,[MixedAmount] - ) - --- | * Full account name, --- --- * ledger-style short account name (the leaf name, prefixed by any boring parents immediately above), --- --- * indentation steps to use when rendering a ledger-style account tree --- (the 0-based depth of this account excluding boring parents; or with --flat, 0) -type RenderableAccountName = - (AccountName - ,AccountName - ,Int - ) - -instance Show MultiBalanceReport where - -- use ppShow to break long lists onto multiple lines - -- we have to add some bogus extra shows here to help ppShow parse the output - -- and wrap tuples and lists properly - show (MultiBalanceReport (spans, items, totals)) = - "MultiBalanceReport (ignore extra quotes):\n" ++ ppShow (show spans, map show items, totals) - --- | Select accounts and get their period balance (change of balance) in each --- period, plus misc. display information, for a period balance report. -periodBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport -periodBalanceReport opts q j = MultiBalanceReport (spans, items, totals) - where - (q',depthq) = (filterQuery (not . queryIsDepth) q, filterQuery queryIsDepth q) - clip = filter (depthq `matchesAccount`) - j' = filterJournalPostings q' $ journalSelectingAmountFromOpts opts j - ps = journalPostings j' - - -- the requested span is the span of the query (which is - -- based on -b/-e/-p opts and query args IIRC). - requestedspan = queryDateSpan (date2_ opts) q - - -- the report's span will be the requested span intersected with - -- the selected data's span; or with -E, the requested span - -- limited by the journal's overall span. - reportspan | empty_ opts = requestedspan `orDatesFrom` journalspan - | otherwise = requestedspan `spanIntersect` matchedspan - where - journalspan = journalDateSpan j' - matchedspan = postingsDateSpan ps - - -- first implementation, probably inefficient - spans = dbg "1 " $ splitSpan (intervalFromOpts opts) reportspan - psPerSpan = dbg "3" $ [filter (isPostingInDateSpan s) ps | s <- spans] - acctnames = dbg "4" $ sort $ clip $ - -- expandAccountNames $ - accountNamesFromPostings ps - allAcctsZeros = dbg "5" $ [(a, nullmixedamt) | a <- acctnames] - someAcctBalsPerSpan = dbg "6" $ [[(aname a, aibalance a) | a <- drop 1 $ accountsFromPostings ps, depthq `matchesAccount` aname a, aname a `elem` acctnames] | ps <- psPerSpan] - balsPerSpan = dbg "7" $ [sortBy (comparing fst) $ unionBy (\(a,_) (a',_) -> a == a') acctbals allAcctsZeros | acctbals <- someAcctBalsPerSpan] - balsPerAcct = dbg "8" $ transpose balsPerSpan - acctsAndBals = dbg "8.5" $ zip acctnames (map (map snd) balsPerAcct) - items = dbg "9" $ [((a, a, accountNameLevel a), bs) | (a,bs) <- acctsAndBals, empty_ opts || any (not . isZeroMixedAmount) bs] - highestLevelBalsPerSpan = - dbg "9.5" $ [[b | (a,b) <- spanbals, not $ any (`elem` acctnames) $ init $ expandAccountName a] | spanbals <- balsPerSpan] - totals = dbg "10" $ map sum highestLevelBalsPerSpan - -------------------------------------------------------------------------------- - --- | Calculate the overall span and per-period date spans for a report --- based on command-line options, the parsed search query, and the --- journal data. If a reporting interval is specified, the report span --- will be enlarged to include a whole number of report periods. --- Reports will sometimes trim these spans further when appropriate. -reportSpans :: ReportOpts -> Query -> Journal -> (DateSpan, [DateSpan]) -reportSpans opts q j = (reportspan, spans) - where - -- get the requested span from the query, which is based on - -- -b/-e/-p opts and query args. - requestedspan = queryDateSpan (date2_ opts) q - - -- set the start and end date to the journal's if not specified - requestedspan' = requestedspan `orDatesFrom` journalDateSpan j - - -- if there's a reporting interval, calculate the report periods - -- which enclose the requested span - spans = dbg "spans" $ splitSpan (intervalFromOpts opts) requestedspan' - - -- the overall report span encloses the periods - reportspan = DateSpan - (maybe Nothing spanStart $ headMay spans) - (maybe Nothing spanEnd $ lastMay spans) - --- | Select accounts and get their ending balance in each period, plus --- account name display information, for a cumulative or historical balance report. -cumulativeOrHistoricalBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport -cumulativeOrHistoricalBalanceReport opts q j = MultiBalanceReport (periodbalancespans, items, totals) - where - -- select/adjust basic report dates - (reportspan, _) = reportSpans opts q j - - -- rewrite query to use adjusted dates - dateless = filterQuery (not . queryIsDate) - depthless = filterQuery (not . queryIsDepth) - q' = dateless $ depthless q - -- reportq = And [q', Date reportspan] - - -- get starting balances and accounts from preceding txns - precedingq = And [q', Date $ DateSpan Nothing (spanStart reportspan)] - (startbalanceitems,_) = balanceReport opts{flat_=True,empty_=True} precedingq j - startacctbals = dbg "startacctbals" $ map (\(a,_,_,b) -> (a,b)) startbalanceitems - -- acctsWithStartingBalance = map fst $ filter (not . isZeroMixedAmount . snd) startacctbals - startingBalanceFor a | balancetype_ opts == HistoricalBalance = fromMaybe nullmixedamt $ lookup a startacctbals - | otherwise = nullmixedamt - - -- get balance changes by period - MultiBalanceReport (periodbalancespans,periodbalanceitems,_) = dbg "changes" $ periodBalanceReport opts q j - balanceChangesByAcct = map (\((a,_,_),bs) -> (a,bs)) periodbalanceitems - acctsWithBalanceChanges = map fst $ filter ((any (not . isZeroMixedAmount)) . snd) balanceChangesByAcct - balanceChangesFor a = fromMaybe (error $ "no data for account: a") $ -- XXX - lookup a balanceChangesByAcct - - -- accounts to report on - reportaccts -- = dbg' "reportaccts" $ (dbg' "acctsWithStartingBalance" acctsWithStartingBalance) `union` (dbg' "acctsWithBalanceChanges" acctsWithBalanceChanges) - = acctsWithBalanceChanges - - -- sum balance changes to get ending balances for each period - endingBalancesFor a = - dbg "ending balances" $ drop 1 $ scanl (+) (startingBalanceFor a) $ - dbg "balance changes" $ balanceChangesFor a - - items = dbg "items" $ [((a,a,0), endingBalancesFor a) | a <- reportaccts] - - -- sum highest-level account balances in each column for column totals - totals = dbg "totals" $ map sum highestlevelbalsbycol - where - highestlevelbalsbycol = transpose $ map endingBalancesFor highestlevelaccts - highestlevelaccts = - dbg "highestlevelaccts" $ - [a | a <- reportaccts, not $ any (`elem` reportaccts) $ init $ expandAccountName a] - - -- enable to debug just this function - -- dbg :: Show a => String -> a -> a - -- dbg = lstrace - -------------------------------------------------------------------------------- - --- | Get the historical running inclusive balance of a particular account, --- from earliest to latest posting date. --- XXX Accounts should know the Ledger & Journal they came from -accountBalanceHistory :: ReportOpts -> Journal -> Account -> [(Day, MixedAmount)] -accountBalanceHistory ropts j a = [(getdate t, bal) | (t,_,_,_,_,bal) <- items] - where - (_,items) = journalTransactionsReport ropts j acctquery - inclusivebal = True - acctquery = Acct $ (if inclusivebal then accountNameToAccountRegex else accountNameToAccountOnlyRegex) $ aname a - getdate = if date2_ ropts then transactionDate2 else tdate - - -------------------------------------------------------------------------------- --- TESTS - -tests_postingsReport = [ - "postingsReport" ~: do - - -- with the query specified explicitly - 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 - (And [Depth 1, Status True, Acct "expenses"], samplejournal) `gives` 2 - (And [And [Depth 1, Status True], Acct "expenses"], samplejournal) `gives` 2 - - -- with query and/or command-line options - 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" - ] - --} - ] - -tests_balanceReport = - let (opts,journal) `gives` r = do - let (eitems, etotal) = r - (aitems, atotal) = balanceReport opts (queryFromOpts nulldate opts) journal - assertEqual "items" eitems aitems - -- assertEqual "" (length eitems) (length aitems) - -- mapM (\(e,a) -> assertEqual "" e a) $ zip eitems aitems - assertEqual "total" etotal atotal - in [ - - "balanceReport with no args on null journal" ~: do - (defreportopts, nulljournal) `gives` ([], Mixed [nullamt]) - - ,"balanceReport with no args on sample journal" ~: do - (defreportopts, samplejournal) `gives` - ([ - ("assets","assets",0, mamountp' "$-1.00") - ,("assets:bank:saving","bank:saving",1, mamountp' "$1.00") - ,("assets:cash","cash",1, mamountp' "$-2.00") - ,("expenses","expenses",0, mamountp' "$2.00") - ,("expenses:food","food",1, mamountp' "$1.00") - ,("expenses:supplies","supplies",1, mamountp' "$1.00") - ,("income","income",0, mamountp' "$-2.00") - ,("income:gifts","gifts",1, mamountp' "$-1.00") - ,("income:salary","salary",1, mamountp' "$-1.00") - ,("liabilities:debts","liabilities:debts",0, mamountp' "$1.00") - ], - Mixed [nullamt]) - - ,"balanceReport with --depth=N" ~: do - (defreportopts{depth_=Just 1}, samplejournal) `gives` - ([ - ("assets", "assets", 0, mamountp' "$-1.00") - ,("expenses", "expenses", 0, mamountp' "$2.00") - ,("income", "income", 0, mamountp' "$-2.00") - ,("liabilities", "liabilities", 0, mamountp' "$1.00") - ], - Mixed [nullamt]) - - ,"balanceReport with depth:N" ~: do - (defreportopts{query_="depth:1"}, samplejournal) `gives` - ([ - ("assets", "assets", 0, mamountp' "$-1.00") - ,("expenses", "expenses", 0, mamountp' "$2.00") - ,("income", "income", 0, mamountp' "$-2.00") - ,("liabilities", "liabilities", 0, mamountp' "$1.00") - ], - Mixed [nullamt]) - - ,"balanceReport with a date or secondary date span" ~: do - (defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives` - ([], - Mixed [nullamt]) - (defreportopts{query_="edate:'in 2009'"}, samplejournal2) `gives` - ([ - ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00") - ,("income:salary","income:salary",0,mamountp' "$-1.00") - ], - Mixed [nullamt]) - - ,"balanceReport with desc:" ~: do - (defreportopts{query_="desc:income"}, samplejournal) `gives` - ([ - ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00") - ,("income:salary","income:salary",0, mamountp' "$-1.00") - ], - Mixed [nullamt]) - - ,"balanceReport with not:desc:" ~: do - (defreportopts{query_="not:desc:income"}, samplejournal) `gives` - ([ - ("assets","assets",0, mamountp' "$-2.00") - ,("assets:bank","bank",1, Mixed [nullamt]) - ,("assets:bank:checking","checking",2,mamountp' "$-1.00") - ,("assets:bank:saving","saving",2, mamountp' "$1.00") - ,("assets:cash","cash",1, mamountp' "$-2.00") - ,("expenses","expenses",0, mamountp' "$2.00") - ,("expenses:food","food",1, mamountp' "$1.00") - ,("expenses:supplies","supplies",1, mamountp' "$1.00") - ,("income:gifts","income:gifts",0, mamountp' "$-1.00") - ,("liabilities:debts","liabilities:debts",0, mamountp' "$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 - balanceReportAsText defreportopts (balanceReport defreportopts Any j') `is` - [" $500 a:b" - ," $-500 c:d" - ,"--------------------" - ," 0" - ] --} - ] - -Right samplejournal2 = journalBalanceTransactions $ - nulljournal - {jtxns = [ - txnTieKnot $ Transaction { - tdate=parsedate "2008/01/01", - tdate2=Just $ parsedate "2009/01/01", - tstatus=False, - tcode="", - tdescription="income", - tcomment="", - ttags=[], - tpostings= - [posting {paccount="assets:bank:checking", pamount=Mixed [usd 1]} - ,posting {paccount="income:salary", pamount=missingmixedamt} - ], - tpreceding_comment_lines="" - } - ] - } - --- tests_isInterestingIndented = [ --- "isInterestingIndented" ~: do --- let (opts, journal, acctname) `gives` r = isInterestingIndented opts l acctname `is` r --- where l = ledgerFromJournal (queryFromOpts nulldate opts) journal - --- (defreportopts, samplejournal, "expenses") `gives` True --- ] - -tests_Hledger_Reports :: Test -tests_Hledger_Reports = TestList $ - tests_queryFromOpts - ++ tests_queryOptsFromOpts - ++ tests_entriesReport - ++ tests_summarisePostingsByInterval - ++ tests_postingsReport - -- ++ tests_isInterestingIndented - ++ tests_balanceReport - ++ [ - -- ,"summarisePostingsInDateSpan" ~: do - -- let gives (b,e,depth,showempty,ps) = - -- (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`) - -- let ps = - -- [ - -- nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]} - -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [usd 2]} - -- ,nullposting{lpdescription="desc",lpaccount="expenses:food", lpamount=Mixed [usd 4]} - -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [usd 8]} - -- ] - -- ("2008/01/01","2009/01/01",0,9999,False,[]) `gives` - -- [] - -- ("2008/01/01","2009/01/01",0,9999,True,[]) `gives` - -- [ - -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31"} - -- ] - -- ("2008/01/01","2009/01/01",0,9999,False,ts) `gives` - -- [ - -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food", lpamount=Mixed [usd 4]} - -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining", lpamount=Mixed [usd 10]} - -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]} - -- ] - -- ("2008/01/01","2009/01/01",0,2,False,ts) `gives` - -- [ - -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [usd 15]} - -- ] - -- ("2008/01/01","2009/01/01",0,1,False,ts) `gives` - -- [ - -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [usd 15]} - -- ] - -- ("2008/01/01","2009/01/01",0,0,False,ts) `gives` - -- [ - -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [usd 15]} - -- ] - + module Hledger.Reports.ReportOptions, + module Hledger.Reports.EntriesReport, + module Hledger.Reports.PostingsReport, + module Hledger.Reports.TransactionsReports, + module Hledger.Reports.BalanceReport, + module Hledger.Reports.MultiBalanceReports, + module Hledger.Reports.BalanceHistoryReport, + + -- * Tests + tests_Hledger_Reports +) +where + +import Test.HUnit + +import Hledger.Reports.ReportOptions +import Hledger.Reports.EntriesReport +import Hledger.Reports.PostingsReport +import Hledger.Reports.TransactionsReports +import Hledger.Reports.BalanceReport +import Hledger.Reports.MultiBalanceReports +import Hledger.Reports.BalanceHistoryReport + +tests_Hledger_Reports :: Test +tests_Hledger_Reports = TestList $ + -- ++ tests_isInterestingIndented + [ + tests_Hledger_Reports_ReportOptions, + tests_Hledger_Reports_EntriesReport, + tests_Hledger_Reports_PostingsReport, + tests_Hledger_Reports_BalanceReport ] diff --git a/Hledger/Reports/BalanceHistoryReport.hs b/Hledger/Reports/BalanceHistoryReport.hs new file mode 100644 --- /dev/null +++ b/Hledger/Reports/BalanceHistoryReport.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} +{-| + +Account balance history report. + +-} + +module Hledger.Reports.BalanceHistoryReport ( + accountBalanceHistory + + -- -- * Tests + -- tests_Hledger_Reports_BalanceReport +) +where + +import Data.Time.Calendar +-- import Test.HUnit + +import Hledger.Data +import Hledger.Query +import Hledger.Reports.ReportOptions +import Hledger.Reports.TransactionsReports + + +-- | Get the historical running inclusive balance of a particular account, +-- from earliest to latest posting date. +accountBalanceHistory :: ReportOpts -> Journal -> Account -> [(Day, MixedAmount)] +accountBalanceHistory ropts j a = [(getdate t, bal) | (t,_,_,_,_,bal) <- items] + where + (_,items) = journalTransactionsReport ropts j acctquery + inclusivebal = True + acctquery = Acct $ (if inclusivebal then accountNameToAccountRegex else accountNameToAccountOnlyRegex) $ aname a + getdate = if date2_ ropts then transactionDate2 else tdate + diff --git a/Hledger/Reports/BalanceReport.hs b/Hledger/Reports/BalanceReport.hs new file mode 100644 --- /dev/null +++ b/Hledger/Reports/BalanceReport.hs @@ -0,0 +1,349 @@ +{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables #-} +{-| + +Balance report, used by the balance command. + +-} + +module Hledger.Reports.BalanceReport ( + BalanceReport, + BalanceReportItem, + RenderableAccountName, + balanceReport, + flatShowsExclusiveBalance, + + -- * Tests + tests_Hledger_Reports_BalanceReport +) +where + +import Data.Maybe +import Test.HUnit + +import Hledger.Data +import Hledger.Read (mamountp') +import Hledger.Query +import Hledger.Utils +import Hledger.Reports.ReportOptions + + +-- | A simple single-column balance report. It has: +-- +-- 1. a list of rows, each containing a renderable account name and a corresponding amount +-- +-- 2. the final total of the amounts +type BalanceReport = ([BalanceReportItem], MixedAmount) +type BalanceReportItem = (RenderableAccountName, MixedAmount) + +-- | A renderable account name includes some additional hints for rendering accounts in a balance report. +-- It has: +-- +-- * The full account name +-- +-- * The ledger-style short elided account name (the leaf name, prefixed by any boring parents immediately above) +-- +-- * The number of indentation steps to use when rendering a ledger-style account tree +-- (normally the 0-based depth of this account excluding boring parents, or 0 with --flat). +type RenderableAccountName = (AccountName, AccountName, Int) + +-- | When true (the default), this makes balance --flat reports and their implementation clearer. +-- Single/multi-col balance reports currently aren't all correct if this is false. +flatShowsExclusiveBalance = True + +-- | Enabling this makes balance --flat --empty also show parent accounts without postings, +-- in addition to those with postings and a zero balance. Disabling it shows only the latter. +-- No longer supported, but leave this here for a bit. +-- flatShowsPostinglessAccounts = True + +-- | Generate a simple balance report, containing the matched accounts and +-- their balances (change of balance) during the specified period. +-- This is like periodBalanceReport with a single column (but more mature, +-- eg this can do hierarchical display). +balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport +balanceReport opts q j = (items, total) + where + -- dbg = const id -- exclude from debug output + dbg s = let p = "balanceReport" in Hledger.Utils.dbg (p++" "++s) -- add prefix in debug output + + accts = ledgerRootAccount $ ledgerFromJournal q $ journalSelectingAmountFromOpts opts j + accts' :: [Account] + | flat_ opts = dbg "accts" $ + filterzeros $ + filterempty $ + drop 1 $ clipAccountsAndAggregate (queryDepth q) $ flattenAccounts accts + | otherwise = dbg "accts" $ + filter (not.aboring) $ + drop 1 $ flattenAccounts $ + markboring $ + prunezeros $ clipAccounts (queryDepth q) accts + where + balance = if flat_ opts then aebalance else aibalance + filterzeros = if empty_ opts then id else filter (not . isZeroMixedAmount . balance) + filterempty = filter (\a -> anumpostings a > 0 || not (isZeroMixedAmount (balance a))) + prunezeros = if empty_ opts then id else fromMaybe nullacct . pruneAccounts (isZeroMixedAmount . balance) + markboring = if no_elide_ opts then id else markBoringParentAccounts + items = dbg "items" $ map (balanceReportItem opts q) accts' + total | not (flat_ opts) = dbg "total" $ sum [amt | ((_,_,indent),amt) <- items, indent == 0] + | otherwise = dbg "total" $ + if flatShowsExclusiveBalance + then sum $ map snd items + else sum $ map aebalance $ clipAccountsAndAggregate 1 accts' + +-- | In an account tree with zero-balance leaves removed, mark the +-- elidable parent accounts (those with one subaccount and no balance +-- of their own). +markBoringParentAccounts :: Account -> Account +markBoringParentAccounts = tieAccountParents . mapAccounts mark + where + mark a | length (asubs a) == 1 && isZeroMixedAmount (aebalance a) = a{aboring=True} + | otherwise = a + +balanceReportItem :: ReportOpts -> Query -> Account -> BalanceReportItem +balanceReportItem opts _ a@Account{aname=name} + | flat_ opts = ((name, name, 0), (if flatShowsExclusiveBalance then aebalance else aibalance) a) + | otherwise = ((name, elidedname, indent), aibalance a) + where + elidedname = accountNameFromComponents (adjacentboringparentnames ++ [accountLeafName name]) + adjacentboringparentnames = reverse $ map (accountLeafName.aname) $ takeWhile aboring $ parents + indent = length $ filter (not.aboring) parents + parents = init $ parentAccounts a + +-- -- the above using the newer multi balance report code: +-- balanceReport' opts q j = (items, total) +-- where +-- MultiBalanceReport (_,mbrrows,mbrtotals) = periodBalanceReport opts q j +-- items = [(a,a',n, headDef 0 bs) | ((a,a',n), bs) <- mbrrows] +-- total = headDef 0 mbrtotals + +tests_balanceReport = + let (opts,journal) `gives` r = do + let (eitems, etotal) = r + (aitems, atotal) = balanceReport opts (queryFromOpts nulldate opts) journal + assertEqual "items" eitems aitems + -- assertEqual "" (length eitems) (length aitems) + -- mapM (\(e,a) -> assertEqual "" e a) $ zip eitems aitems + assertEqual "total" etotal atotal + in [ + + "balanceReport with no args on null journal" ~: do + (defreportopts, nulljournal) `gives` ([], Mixed [nullamt]) + + ,"balanceReport with no args on sample journal" ~: do + (defreportopts, samplejournal) `gives` + ([ + (("assets","assets",0), mamountp' "$-1.00") + ,(("assets:bank:saving","bank:saving",1), mamountp' "$1.00") + ,(("assets:cash","cash",1), mamountp' "$-2.00") + ,(("expenses","expenses",0), mamountp' "$2.00") + ,(("expenses:food","food",1), mamountp' "$1.00") + ,(("expenses:supplies","supplies",1), mamountp' "$1.00") + ,(("income","income",0), mamountp' "$-2.00") + ,(("income:gifts","gifts",1), mamountp' "$-1.00") + ,(("income:salary","salary",1), mamountp' "$-1.00") + ,(("liabilities:debts","liabilities:debts",0), mamountp' "$1.00") + ], + Mixed [nullamt]) + + ,"balanceReport with --depth=N" ~: do + (defreportopts{depth_=Just 1}, samplejournal) `gives` + ([ + (("assets", "assets", 0), mamountp' "$-1.00") + ,(("expenses", "expenses", 0), mamountp' "$2.00") + ,(("income", "income", 0), mamountp' "$-2.00") + ,(("liabilities", "liabilities", 0), mamountp' "$1.00") + ], + Mixed [nullamt]) + + ,"balanceReport with depth:N" ~: do + (defreportopts{query_="depth:1"}, samplejournal) `gives` + ([ + (("assets", "assets", 0), mamountp' "$-1.00") + ,(("expenses", "expenses", 0), mamountp' "$2.00") + ,(("income", "income", 0), mamountp' "$-2.00") + ,(("liabilities", "liabilities", 0), mamountp' "$1.00") + ], + Mixed [nullamt]) + + ,"balanceReport with a date or secondary date span" ~: do + (defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives` + ([], + Mixed [nullamt]) + (defreportopts{query_="edate:'in 2009'"}, samplejournal2) `gives` + ([ + (("assets:bank:checking","assets:bank:checking",0),mamountp' "$1.00") + ,(("income:salary","income:salary",0),mamountp' "$-1.00") + ], + Mixed [nullamt]) + + ,"balanceReport with desc:" ~: do + (defreportopts{query_="desc:income"}, samplejournal) `gives` + ([ + (("assets:bank:checking","assets:bank:checking",0),mamountp' "$1.00") + ,(("income:salary","income:salary",0), mamountp' "$-1.00") + ], + Mixed [nullamt]) + + ,"balanceReport with not:desc:" ~: do + (defreportopts{query_="not:desc:income"}, samplejournal) `gives` + ([ + (("assets","assets",0), mamountp' "$-2.00") + ,(("assets:bank","bank",1), Mixed [nullamt]) + ,(("assets:bank:checking","checking",2),mamountp' "$-1.00") + ,(("assets:bank:saving","saving",2), mamountp' "$1.00") + ,(("assets:cash","cash",1), mamountp' "$-2.00") + ,(("expenses","expenses",0), mamountp' "$2.00") + ,(("expenses:food","food",1), mamountp' "$1.00") + ,(("expenses:supplies","supplies",1), mamountp' "$1.00") + ,(("income:gifts","income:gifts",0), mamountp' "$-1.00") + ,(("liabilities:debts","liabilities:debts",0), mamountp' "$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 + balanceReportAsText defreportopts (balanceReport defreportopts Any j') `is` + [" $500 a:b" + ," $-500 c:d" + ,"--------------------" + ," 0" + ] +-} + ] + +Right samplejournal2 = journalBalanceTransactions $ + nulljournal + {jtxns = [ + txnTieKnot $ Transaction { + tdate=parsedate "2008/01/01", + tdate2=Just $ parsedate "2009/01/01", + tstatus=False, + tcode="", + tdescription="income", + tcomment="", + ttags=[], + tpostings= + [posting {paccount="assets:bank:checking", pamount=Mixed [usd 1]} + ,posting {paccount="income:salary", pamount=missingmixedamt} + ], + tpreceding_comment_lines="" + } + ] + } + +-- tests_isInterestingIndented = [ +-- "isInterestingIndented" ~: do +-- let (opts, journal, acctname) `gives` r = isInterestingIndented opts l acctname `is` r +-- where l = ledgerFromJournal (queryFromOpts nulldate opts) journal + +-- (defreportopts, samplejournal, "expenses") `gives` True +-- ] + +tests_Hledger_Reports_BalanceReport :: Test +tests_Hledger_Reports_BalanceReport = TestList $ + tests_balanceReport diff --git a/Hledger/Reports/EntriesReport.hs b/Hledger/Reports/EntriesReport.hs new file mode 100644 --- /dev/null +++ b/Hledger/Reports/EntriesReport.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} +{-| + +Journal entries report, used by the print command. + +-} + +module Hledger.Reports.EntriesReport ( + EntriesReport, + EntriesReportItem, + entriesReport, + -- * Tests + tests_Hledger_Reports_EntriesReport +) +where + +import Data.List +import Data.Ord +import Test.HUnit + +import Hledger.Data +import Hledger.Query +import Hledger.Reports.ReportOptions + + +-- | A journal entries report is a list of whole transactions as +-- originally entered in the journal (mostly). This is used by eg +-- hledger's print command and hledger-web's journal entries view. +type EntriesReport = [EntriesReportItem] +type EntriesReportItem = Transaction + +-- | Select transactions for an entries report. +entriesReport :: ReportOpts -> Query -> Journal -> EntriesReport +entriesReport opts q j = + sortBy (comparing date) $ filter (q `matchesTransaction`) ts + where + date = transactionDateFn opts + ts = jtxns $ journalSelectingAmountFromOpts opts j + +tests_entriesReport :: [Test] +tests_entriesReport = [ + "entriesReport" ~: do + assertEqual "not acct" 1 (length $ entriesReport defreportopts (Not $ Acct "bank") samplejournal) + let sp = mkdatespan "2008/06/01" "2008/07/01" + assertEqual "date" 3 (length $ entriesReport defreportopts (Date sp) samplejournal) + ] + +tests_Hledger_Reports_EntriesReport :: Test +tests_Hledger_Reports_EntriesReport = TestList $ + tests_entriesReport + diff --git a/Hledger/Reports/MultiBalanceReports.hs b/Hledger/Reports/MultiBalanceReports.hs new file mode 100644 --- /dev/null +++ b/Hledger/Reports/MultiBalanceReports.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables #-} +{-| + +Multi-column balance reports, used by the balance command. + +-} + +module Hledger.Reports.MultiBalanceReports ( + MultiBalanceReport(..), + MultiBalanceReportRow, + multiBalanceReport + + -- -- * Tests + -- tests_Hledger_Reports_MultiBalanceReport +) +where + +import Data.List +import Data.Maybe +import Data.Ord +import Safe +-- import Test.HUnit + +import Hledger.Data +import Hledger.Query +import Hledger.Utils +import Hledger.Reports.ReportOptions +import Hledger.Reports.BalanceReport + + +-- | A multi balance report is a balance report with one or more columns. It has: +-- +-- 1. a list of each column's date span +-- +-- 2. a list of rows, each containing a renderable account name and the amounts to show in each column +-- +-- 3. a list of each column's final total +-- +-- The meaning of the amounts depends on the type of multi balance +-- report, of which there are three: periodic, cumulative and historical +-- (see 'BalanceType' and "Hledger.Cli.Balance"). +newtype MultiBalanceReport = MultiBalanceReport ([DateSpan] + ,[MultiBalanceReportRow] + ,[MixedAmount] + ) + +-- | A row in a multi balance report has +-- +-- * An account name, with rendering hints +-- +-- * A list of amounts to be shown in each of the report's columns. +type MultiBalanceReportRow = (RenderableAccountName, [MixedAmount]) + +instance Show MultiBalanceReport where + -- use ppShow to break long lists onto multiple lines + -- we add some bogus extra shows here to help ppShow parse the output + -- and wrap tuples and lists properly + show (MultiBalanceReport (spans, items, totals)) = + "MultiBalanceReport (ignore extra quotes):\n" ++ ppShow (show spans, map show items, totals) + +-- type alias just to remind us which AccountNames might be depth-clipped, below. +type ClippedAccountName = AccountName + +-- | Generate a multicolumn balance report for the matched accounts, +-- showing the change of balance, accumulated balance, or historical balance +-- in each of the specified periods. +multiBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport +multiBalanceReport opts q j = MultiBalanceReport (displayspans, items, totals) + where + symq = dbg "symq" $ filterQuery queryIsSym $ dbg "requested q" q + depthq = dbg "depthq" $ filterQuery queryIsDepth q + depth = queryDepth depthq + depthless = dbg "depthless" . filterQuery (not . queryIsDepth) + datelessq = dbg "datelessq" $ filterQuery (not . queryIsDate) q + dateqcons = if date2_ opts then Date2 else Date + precedingq = dbg "precedingq" $ And [datelessq, dateqcons $ DateSpan Nothing (spanStart reportspan)] + requestedspan = dbg "requestedspan" $ queryDateSpan (date2_ opts) q -- span specified by -b/-e/-p options and query args + requestedspan' = dbg "requestedspan'" $ requestedspan `spanDefaultsFrom` journalDateSpan (date2_ opts) j -- if open-ended, close it using the journal's end dates + intervalspans = dbg "intervalspans" $ splitSpan (intervalFromOpts opts) requestedspan' -- interval spans enclosing it + reportspan = dbg "reportspan" $ DateSpan (maybe Nothing spanStart $ headMay intervalspans) -- the requested span enlarged to a whole number of intervals + (maybe Nothing spanEnd $ lastMay intervalspans) + newdatesq = dbg "newdateq" $ dateqcons reportspan + reportq = dbg "reportq" $ depthless $ And [datelessq, newdatesq] -- user's query enlarged to whole intervals and with no depth limit + + ps :: [Posting] = + dbg "ps" $ + journalPostings $ + filterJournalPostingAmounts symq $ -- remove amount parts excluded by cur: + filterJournalPostings reportq $ -- remove postings not matched by (adjusted) query + journalSelectingAmountFromOpts opts j + + displayspans = dbg "displayspans" $ splitSpan (intervalFromOpts opts) displayspan + where + displayspan + | empty_ opts = dbg "displayspan (-E)" $ reportspan -- all the requested intervals + | otherwise = dbg "displayspan" $ requestedspan `spanIntersect` matchedspan -- exclude leading/trailing empty intervals + matchedspan = dbg "matchedspan" $ postingsDateSpan' (whichDateFromOpts opts) ps + + psPerSpan :: [[Posting]] = + dbg "psPerSpan" $ + [filter (isPostingInDateSpan' (whichDateFromOpts opts) s) ps | s <- displayspans] + + postedAcctBalChangesPerSpan :: [[(ClippedAccountName, MixedAmount)]] = + dbg "postedAcctBalChangesPerSpan" $ + map postingAcctBals psPerSpan + where + postingAcctBals :: [Posting] -> [(ClippedAccountName, MixedAmount)] + postingAcctBals ps = [(aname a, (if tree_ opts then aibalance else aebalance) a) | a <- as] + where + as = depthLimit $ + (if tree_ opts then id else filter ((>0).anumpostings)) $ + drop 1 $ accountsFromPostings ps + depthLimit + | tree_ opts = filter ((depthq `matchesAccount`).aname) -- exclude deeper balances + | otherwise = clipAccountsAndAggregate depth -- aggregate deeper balances at the depth limit + + postedAccts :: [AccountName] = + dbg "postedAccts" $ + sort $ accountNamesFromPostings ps + + displayedAccts :: [ClippedAccountName] = + dbg "displayedAccts" $ + (if tree_ opts then expandAccountNames else id) $ + nub $ map (clipAccountName depth) postedAccts + + acctBalChangesPerSpan :: [[(ClippedAccountName, MixedAmount)]] = + dbg "acctBalChangesPerSpan" $ + [sortBy (comparing fst) $ unionBy (\(a,_) (a',_) -> a == a') postedacctbals zeroes + | postedacctbals <- postedAcctBalChangesPerSpan] + where zeroes = [(a, nullmixedamt) | a <- displayedAccts] + + acctBalChanges :: [(ClippedAccountName, [MixedAmount])] = + dbg "acctBalChanges" $ + [(a, map snd abs) | abs@((a,_):_) <- transpose acctBalChangesPerSpan] -- never null, or used when null... + + -- starting balances and accounts from transactions before the report start date + startacctbals = dbg "startacctbals" $ map (\((a,_,_),b) -> (a,b)) $ startbalanceitems + where + (startbalanceitems,_) = dbg "starting balance report" $ balanceReport opts' precedingq j + where + opts' | tree_ opts = opts{no_elide_=True} + | otherwise = opts{flat_=True} + startingBalanceFor a = fromMaybe nullmixedamt $ lookup a startacctbals + + items :: [MultiBalanceReportRow] = + dbg "items" $ + [((a, accountLeafName a, accountNameLevel a), displayedBals) + | (a,changes) <- acctBalChanges + , let displayedBals = case balancetype_ opts of + HistoricalBalance -> drop 1 $ scanl (+) (startingBalanceFor a) changes + CumulativeBalance -> drop 1 $ scanl (+) nullmixedamt changes + _ -> changes + , empty_ opts || any (not . isZeroMixedAmount) displayedBals + ] + + totals :: [MixedAmount] = + dbg "totals" $ + map sum balsbycol + where + balsbycol = transpose [bs | ((a,_,_),bs) <- items, not (tree_ opts) || a `elem` highestlevelaccts] + highestlevelaccts = + dbg "highestlevelaccts" $ + [a | a <- displayedAccts, not $ any (`elem` displayedAccts) $ init $ expandAccountName a] + + dbg s = let p = "multiBalanceReport" in Hledger.Utils.dbg (p++" "++s) -- add prefix in debug output + -- dbg = const id -- exclude from debug output + diff --git a/Hledger/Reports/PostingsReport.hs b/Hledger/Reports/PostingsReport.hs new file mode 100644 --- /dev/null +++ b/Hledger/Reports/PostingsReport.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} +{-| + +Postings report, used by the register command. + +-} + +module Hledger.Reports.PostingsReport ( + PostingsReport, + PostingsReportItem, + postingsReport, + mkpostingsReportItem, + + -- * Tests + tests_Hledger_Reports_PostingsReport +) +where + +import Data.List +import Data.Maybe +import Data.Time.Calendar +import Safe (headMay, lastMay) +import Test.HUnit + +import Hledger.Data +import Hledger.Query +import Hledger.Utils +import Hledger.Reports.ReportOptions + + +-- | A postings report is a list of postings with a running total, a label +-- for the total field, and a little extra transaction info to help with rendering. +-- This is used eg for the register command. +type PostingsReport = (String -- label for the running balance column XXX remove + ,[PostingsReportItem] -- line items, one per posting + ) +type PostingsReportItem = (Maybe Day -- posting date, if this is the first posting in a transaction or if it's different from the previous posting's date + ,Maybe String -- transaction description, if this is the first posting in a transaction + ,Posting -- the posting, possibly with account name depth-clipped + ,MixedAmount -- the running total after this posting (or with --average, the running average) + ) + +-- | 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 -> Query -> Journal -> PostingsReport +postingsReport opts q j = (totallabel, items) + where + -- figure out adjusted queries & spans like multiBalanceReport + symq = dbg "symq" $ filterQuery queryIsSym $ dbg "requested q" q + depth = queryDepth q + depthless = filterQuery (not . queryIsDepth) + datelessq = filterQuery (not . queryIsDate) q + dateqcons = if date2_ opts then Date2 else Date + requestedspan = dbg "requestedspan" $ queryDateSpan (date2_ opts) q -- span specified by -b/-e/-p options and query args + requestedspan' = dbg "requestedspan'" $ requestedspan `spanDefaultsFrom` journalDateSpan (date2_ opts) j -- if open-ended, close it using the journal's end dates + intervalspans = dbg "intervalspans" $ splitSpan (intervalFromOpts opts) requestedspan' -- interval spans enclosing it + reportstart = dbg "reportstart" $ maybe Nothing spanStart $ headMay intervalspans + reportend = dbg "reportend" $ maybe Nothing spanEnd $ lastMay intervalspans + reportspan = dbg "reportspan" $ DateSpan reportstart reportend -- the requested span enlarged to a whole number of intervals + beforestartq = dbg "beforestartq" $ dateqcons $ DateSpan Nothing reportstart + beforeendq = dbg "beforeendq" $ dateqcons $ DateSpan Nothing reportend + reportq = dbg "reportq" $ depthless $ And [datelessq, beforeendq] -- user's query with no start date, end date on an interval boundary and no depth limit + + pstoend = + dbg "ps4" $ map (filterPostingAmount symq) $ -- remove amount parts which the query's cur: terms would exclude + dbg "ps3" $ (if related_ opts then concatMap relatedPostings else id) $ -- with -r, replace each with its sibling postings + dbg "ps2" $ filter (reportq `matchesPosting`) $ -- filter postings by the query, including before the report start date, ignoring depth + dbg "ps1" $ journalPostings $ journalSelectingAmountFromOpts opts j + (precedingps, reportps) = dbg "precedingps, reportps" $ span (beforestartq `matchesPosting`) pstoend + + empty = queryEmpty q + -- displayexpr = display_ opts -- XXX + interval = intervalFromOpts opts -- XXX + + whichdate = whichDateFromOpts opts + itemps | interval == NoInterval = reportps + | otherwise = summarisePostingsByInterval interval whichdate depth empty reportspan reportps + items = postingsReportItems itemps nullposting whichdate depth startbal runningcalc 1 + where + startbal = if balancetype_ opts == HistoricalBalance then sumPostings precedingps else 0 + runningcalc | average_ opts = \i avg amt -> avg + (amt - avg) `divideMixedAmount` (fromIntegral i) -- running average + | otherwise = \_ bal amt -> bal + amt -- running total + + dbg s = let p = "postingsReport" in Hledger.Utils.dbg (p++" "++s) -- add prefix in debug output + -- dbg = const id -- exclude from debug output + +totallabel = "Total" + +-- | Generate postings report line items. +postingsReportItems :: [Posting] -> Posting -> WhichDate -> Int -> MixedAmount -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) -> Int -> [PostingsReportItem] +postingsReportItems [] _ _ _ _ _ _ = [] +postingsReportItems (p:ps) pprev wd d b runningcalcfn itemnum = i:(postingsReportItems ps p wd d b' runningcalcfn (itemnum+1)) + where + i = mkpostingsReportItem showdate showdesc wd p' b' + showdate = isfirstintxn || isdifferentdate + showdesc = isfirstintxn + isfirstintxn = ptransaction p /= ptransaction pprev + isdifferentdate = case wd of PrimaryDate -> postingDate p /= postingDate pprev + SecondaryDate -> postingDate2 p /= postingDate2 pprev + p' = p{paccount=clipAccountName d $ paccount p} + b' = runningcalcfn itemnum b (pamount p) + +-- | Generate one postings report line item, containing the posting, +-- the current running balance, and optionally the posting date and/or +-- the transaction description. +mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Posting -> MixedAmount -> PostingsReportItem +mkpostingsReportItem showdate showdesc wd p b = (if showdate then Just date else Nothing, if showdesc then Just desc else Nothing, p, b) + where + date = case wd of PrimaryDate -> postingDate p + SecondaryDate -> postingDate2 p + desc = maybe "" tdescription $ ptransaction p + +-- | Convert a list of postings into summary postings. Summary postings +-- are one per account per interval and aggregated to the specified depth +-- if any. +summarisePostingsByInterval :: Interval -> WhichDate -> Int -> Bool -> DateSpan -> [Posting] -> [Posting] +summarisePostingsByInterval interval wd depth empty reportspan ps = concatMap summarisespan $ splitSpan interval reportspan + where + summarisespan s = summarisePostingsInDateSpan s wd depth empty (postingsinspan s) + postingsinspan s = filter (isPostingInDateSpan' wd s) ps + +tests_summarisePostingsByInterval = [ + "summarisePostingsByInterval" ~: do + summarisePostingsByInterval (Quarters 1) PrimaryDate 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 +-- as a summary for this interval. +-- +-- As usual with date spans the end date is exclusive, but for display +-- purposes we show the previous day as end date, like ledger. +-- +-- When a depth argument is present, postings to accounts of greater +-- depth are aggregated where possible. +-- +-- The showempty flag includes spans with no postings and also postings +-- with 0 amount. +summarisePostingsInDateSpan :: DateSpan -> WhichDate -> Int -> Bool -> [Posting] -> [Posting] +summarisePostingsInDateSpan (DateSpan b e) wd depth showempty ps + | null ps && (isNothing b || isNothing e) = [] + | null ps && showempty = [summaryp] + | otherwise = summaryps' + where + summaryp = summaryPosting b' ("- "++ showDate (addDays (-1) e')) + b' = fromMaybe (maybe nulldate postingdate $ headMay ps) b + e' = fromMaybe (maybe (addDays 1 nulldate) postingdate $ lastMay ps) e + postingdate = if wd == PrimaryDate then postingDate else postingDate2 + summaryPosting date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}} + summaryps' = (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps + summaryps = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames] + clippedanames = nub $ map (clipAccountName depth) anames + anames = sort $ nub $ map paccount ps + -- aggregate balances by account, like ledgerFromJournal, then do depth-clipping + accts = accountsFromPostings ps + balance a = maybe nullmixedamt bal $ lookupAccount a accts + where + bal = if isclipped a then aibalance else aebalance + isclipped a = accountNameLevel a >= depth + +-- tests_summarisePostingsInDateSpan = [ + -- "summarisePostingsInDateSpan" ~: do + -- let gives (b,e,depth,showempty,ps) = + -- (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`) + -- let ps = + -- [ + -- nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]} + -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [usd 2]} + -- ,nullposting{lpdescription="desc",lpaccount="expenses:food", lpamount=Mixed [usd 4]} + -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [usd 8]} + -- ] + -- ("2008/01/01","2009/01/01",0,9999,False,[]) `gives` + -- [] + -- ("2008/01/01","2009/01/01",0,9999,True,[]) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31"} + -- ] + -- ("2008/01/01","2009/01/01",0,9999,False,ts) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food", lpamount=Mixed [usd 4]} + -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining", lpamount=Mixed [usd 10]} + -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]} + -- ] + -- ("2008/01/01","2009/01/01",0,2,False,ts) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [usd 15]} + -- ] + -- ("2008/01/01","2009/01/01",0,1,False,ts) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [usd 15]} + -- ] + -- ("2008/01/01","2009/01/01",0,0,False,ts) `gives` + -- [ + -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [usd 15]} + -- ] + +tests_postingsReport = [ + "postingsReport" ~: do + + -- with the query specified explicitly + 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 + (And [Depth 1, Status True, Acct "expenses"], samplejournal) `gives` 2 + (And [And [Depth 1, Status True], Acct "expenses"], samplejournal) `gives` 2 + + -- with query and/or command-line options + 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" + ] + +-} + ] + +tests_Hledger_Reports_PostingsReport :: Test +tests_Hledger_Reports_PostingsReport = TestList $ + tests_summarisePostingsByInterval + ++ tests_postingsReport + diff --git a/Hledger/Reports/ReportOptions.hs b/Hledger/Reports/ReportOptions.hs new file mode 100644 --- /dev/null +++ b/Hledger/Reports/ReportOptions.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-} +{-| + +Options common to most hledger reports. + +-} + +module Hledger.Reports.ReportOptions ( + ReportOpts(..), + BalanceType(..), + FormatStr, + defreportopts, + rawOptsToReportOpts, + dateSpanFromOpts, + intervalFromOpts, + clearedValueFromOpts, + whichDateFromOpts, + journalSelectingAmountFromOpts, + queryFromOpts, + queryFromOptsOnly, + queryOptsFromOpts, + transactionDateFn, + postingDateFn, + + tests_Hledger_Reports_ReportOptions +) +where + +import Data.Data (Data) +import Data.Typeable (Typeable) +import Data.Time.Calendar +import System.Console.CmdArgs.Default -- some additional default stuff +import Test.HUnit + +import Hledger.Data +import Hledger.Query +import Hledger.Utils + + +type FormatStr = String + +-- | Which balance is being shown in a multi-column balance report. +data BalanceType = PeriodBalance -- ^ The change of balance in each period. + | CumulativeBalance -- ^ The accumulated balance at each period's end, starting from zero at the report start date. + | HistoricalBalance -- ^ The historical balance at each period's end, starting from the account balances at the report start date. + deriving (Eq,Show,Data,Typeable) + +instance Default BalanceType where def = PeriodBalance + +-- | 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 + ,period_ :: Maybe (Interval,DateSpan) + ,cleared_ :: Bool + ,uncleared_ :: Bool + ,cost_ :: Bool + ,depth_ :: Maybe Int + ,display_ :: Maybe DisplayExp + ,date2_ :: Bool + ,empty_ :: Bool + ,no_elide_ :: Bool + ,real_ :: Bool + ,daily_ :: Bool + ,weekly_ :: Bool + ,monthly_ :: Bool + ,quarterly_ :: Bool + ,yearly_ :: Bool + ,format_ :: Maybe FormatStr + ,query_ :: String -- all arguments, as a string + -- register + ,average_ :: Bool + ,related_ :: Bool + -- balance + ,balancetype_ :: BalanceType + ,flat_ :: Bool -- mutually + ,tree_ :: Bool -- exclusive + ,drop_ :: Int + ,no_total_ :: Bool + } deriving (Show, Data, Typeable) + +instance Default ReportOpts where def = defreportopts + +defreportopts :: ReportOpts +defreportopts = ReportOpts + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + def + +rawOptsToReportOpts :: RawOpts -> IO ReportOpts +rawOptsToReportOpts rawopts = do + d <- getCurrentDay + return defreportopts{ + begin_ = maybesmartdateopt d "begin" rawopts + ,end_ = maybesmartdateopt d "end" rawopts + ,period_ = maybeperiodopt d rawopts + ,cleared_ = boolopt "cleared" rawopts + ,uncleared_ = boolopt "uncleared" rawopts + ,cost_ = boolopt "cost" rawopts + ,depth_ = maybeintopt "depth" rawopts + ,display_ = maybedisplayopt d rawopts + ,date2_ = boolopt "date2" rawopts + ,empty_ = boolopt "empty" rawopts + ,no_elide_ = boolopt "no-elide" rawopts + ,real_ = boolopt "real" rawopts + ,daily_ = boolopt "daily" rawopts + ,weekly_ = boolopt "weekly" rawopts + ,monthly_ = boolopt "monthly" rawopts + ,quarterly_ = boolopt "quarterly" rawopts + ,yearly_ = boolopt "yearly" rawopts + ,format_ = maybestringopt "format" rawopts + ,query_ = unwords $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right + ,average_ = boolopt "average" rawopts + ,related_ = boolopt "related" rawopts + ,balancetype_ = balancetypeopt rawopts + ,flat_ = boolopt "flat" rawopts + ,tree_ = boolopt "tree" rawopts + ,drop_ = intopt "drop" rawopts + ,no_total_ = boolopt "no-total" rawopts + } + +balancetypeopt :: RawOpts -> BalanceType +balancetypeopt rawopts + | length [o | o <- ["cumulative","historical"], isset o] > 1 + = optserror "please specify at most one of --cumulative and --historical" + | isset "cumulative" = CumulativeBalance + | isset "historical" = HistoricalBalance + | otherwise = PeriodBalance + where + isset = flip boolopt rawopts + +maybesmartdateopt :: Day -> String -> RawOpts -> Maybe Day +maybesmartdateopt d name rawopts = + case maybestringopt name rawopts of + Nothing -> Nothing + Just s -> either + (\e -> optserror $ "could not parse "++name++" date: "++show e) + Just + $ fixSmartDateStrEither' d s + +type DisplayExp = String + +maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExp +maybedisplayopt d rawopts = + maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts + where + fixbracketeddatestr "" = "" + fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]" + +maybeperiodopt :: Day -> RawOpts -> Maybe (Interval,DateSpan) +maybeperiodopt d rawopts = + case maybestringopt "period" rawopts of + Nothing -> Nothing + Just s -> either + (\e -> optserror $ "could not parse period option: "++show e) + Just + $ parsePeriodExpr d s + +-- | Figure out the date span we should report on, based on any +-- begin/end/period options provided. A period option will cause begin and +-- end options to be ignored. +dateSpanFromOpts :: Day -> ReportOpts -> DateSpan +dateSpanFromOpts _ ReportOpts{..} = + case period_ of Just (_,span) -> span + Nothing -> DateSpan begin_ end_ + +-- | Figure out the reporting interval, if any, specified by the options. +-- --period overrides --daily overrides --weekly overrides --monthly etc. +intervalFromOpts :: ReportOpts -> Interval +intervalFromOpts ReportOpts{..} = + case period_ of + Just (interval,_) -> interval + Nothing -> i + where i | daily_ = Days 1 + | weekly_ = Weeks 1 + | monthly_ = Months 1 + | quarterly_ = Quarters 1 + | yearly_ = Years 1 + | otherwise = NoInterval + +-- | Get a maybe boolean representing the last cleared/uncleared option if any. +clearedValueFromOpts :: ReportOpts -> Maybe Bool +clearedValueFromOpts ReportOpts{..} | cleared_ = Just True + | uncleared_ = Just False + | otherwise = Nothing + +-- depthFromOpts :: ReportOpts -> Int +-- depthFromOpts opts = min (fromMaybe 99999 $ depth_ opts) (queryDepth $ queryFromOpts nulldate opts) + +-- | Report which date we will report on based on --date2. +whichDateFromOpts :: ReportOpts -> WhichDate +whichDateFromOpts ReportOpts{..} = if date2_ then SecondaryDate else PrimaryDate + +-- | Select the Transaction date accessor based on --date2. +transactionDateFn :: ReportOpts -> (Transaction -> Day) +transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate + +-- | Select the Posting date accessor based on --date2. +postingDateFn :: ReportOpts -> (Posting -> Day) +postingDateFn ReportOpts{..} = if date2_ then postingDate2 else postingDate + + +-- | Convert this journal's postings' amounts to the cost basis amounts if +-- specified by options. +journalSelectingAmountFromOpts :: ReportOpts -> Journal -> Journal +journalSelectingAmountFromOpts opts + | cost_ opts = journalConvertAmountsToCost + | otherwise = id + +-- | Convert report options and arguments to a query. +queryFromOpts :: Day -> ReportOpts -> Query +queryFromOpts d opts@ReportOpts{..} = simplifyQuery $ And $ [flagsq, argsq] + where + flagsq = And $ + [(if date2_ then Date2 else 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_ + +-- | Convert report options to a query, ignoring any non-flag command line arguments. +queryFromOptsOnly :: Day -> ReportOpts -> Query +queryFromOptsOnly d opts@ReportOpts{..} = simplifyQuery flagsq + where + flagsq = And $ + [(if date2_ then Date2 else Date) $ dateSpanFromOpts d opts] + ++ (if real_ then [Real True] else []) + ++ (if empty_ then [Empty True] else []) -- ? + ++ (maybe [] ((:[]) . Status) (clearedValueFromOpts opts)) + ++ (maybe [] ((:[]) . Depth) depth_) + +tests_queryFromOpts :: [Test] +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 "" (Date2 $ 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 :: [Test] +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'" + }) + ] + + +tests_Hledger_Reports_ReportOptions :: Test +tests_Hledger_Reports_ReportOptions = TestList $ + tests_queryFromOpts + ++ tests_queryOptsFromOpts diff --git a/Hledger/Reports/TransactionsReports.hs b/Hledger/Reports/TransactionsReports.hs new file mode 100644 --- /dev/null +++ b/Hledger/Reports/TransactionsReports.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} +{-| + +Whole-journal, account-centric, and per-commodity transactions reports, used by hledger-web. + +-} + +module Hledger.Reports.TransactionsReports ( + TransactionsReport, + TransactionsReportItem, + triDate, + triBalance, + triSimpleBalance, + journalTransactionsReport, + accountTransactionsReport, + transactionsReportByCommodity + + -- -- * Tests + -- tests_Hledger_Reports_TransactionsReports +) +where + +import Data.List +import Data.Maybe +import Data.Ord +-- import Test.HUnit + +import Hledger.Data +import Hledger.Query +import Hledger.Reports.ReportOptions + + +-- | A transactions report includes a list of transactions +-- (posting-filtered and unfiltered variants), a running balance, and some +-- other information helpful for rendering a register view (a flag +-- indicating multiple other accounts and a display string describing +-- them) with or without a notion of current account(s). +-- Two kinds of report use this data structure, see journalTransactionsReport +-- and accountTransactionsReport below for detais. +type TransactionsReport = (String -- label for the balance column, eg "balance" or "total" + ,[TransactionsReportItem] -- line items, one per transaction + ) +type TransactionsReportItem = (Transaction -- the corresponding transaction + ,Transaction -- the transaction with postings to the current account(s) removed + ,Bool -- is this a split, ie more than one other account posting + ,String -- a display string describing the other account(s), if any + ,MixedAmount -- the amount posted to the current account(s) (or total amount posted) + ,MixedAmount -- the running balance for the current account(s) after this transaction + ) + +triDate (t,_,_,_,_,_) = tdate t +triAmount (_,_,_,_,a,_) = a +triBalance (_,_,_,_,_,a) = a +triSimpleBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0" + (Amount{aquantity=q}):_ -> show q + +------------------------------------------------------------------------------- + +-- | Select transactions from the whole journal. This is similar to a +-- "postingsReport" except with transaction-based report items which +-- are ordered most recent first. This is used by eg hledger-web's journal view. +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 + items = reverse $ accountTransactionsReportItems m Nothing nullmixedamt id ts' + -- XXX items' first element should be the full transaction with all postings + +------------------------------------------------------------------------------- + +-- | Select transactions within one or more current accounts, and make a +-- transactions report relative to those account(s). This means: +-- +-- 1. it shows transactions from the point of view of the current account(s). +-- The transaction amount is the amount posted to the current account(s). +-- The other accounts' names are provided. +-- +-- 2. With no transaction filtering in effect other than a start date, it +-- shows the accurate historical running balance for the current account(s). +-- Otherwise it shows a running total starting at 0. +-- +-- This is used by eg hledger-web's account register view. Currently, +-- reporting intervals are not supported, and report items are most +-- recent first. +accountTransactionsReport :: ReportOpts -> Journal -> Query -> Query -> TransactionsReport +accountTransactionsReport opts j m thisacctquery = (label, items) + where + -- transactions affecting this account, in date order + ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctquery) $ jtxns $ + 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) | queryIsNull m = (nullmixedamt, balancelabel) + | queryIsStartDateOnly (date2_ opts) m = (sumPostings priorps, balancelabel) + | otherwise = (nullmixedamt, totallabel) + where + priorps = -- ltrace "priorps" $ + filter (matchesPosting + (-- ltrace "priormatcher" $ + And [thisacctquery, tostartdatequery])) + $ transactionsPostings ts + tostartdatequery = Date (DateSpan Nothing startdate) + startdate = queryStartDate (date2_ opts) m + items = reverse $ accountTransactionsReportItems m (Just thisacctquery) startbal negate ts + +totallabel = "Total" +balancelabel = "Balance" + +-- | Generate transactions report items from a list of transactions, +-- using the provided query and current account queries, starting balance, +-- sign-setting function and balance-summing function. +accountTransactionsReportItems :: Query -> Maybe Query -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem] +accountTransactionsReportItems _ _ _ _ [] = [] +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 query t + (psthisacct,psotheracct) = case thisacctquery of Just m -> partition (matchesPosting m) psmatched + Nothing -> ([],psmatched) + numotheraccts = length $ nub $ map paccount psotheracct + amt = negate $ sum $ map pamount psthisacct + acct | isNothing thisacctquery = summarisePostings psmatched -- journal register + | numotheraccts == 0 = "transfer between " ++ summarisePostingAccounts psthisacct + | otherwise = prefix ++ summarisePostingAccounts psotheracct + where prefix = maybe "" (\b -> if b then "from " else "to ") $ isNegativeMixedAmount amt + (i,bal') = case psmatched of + [] -> (Nothing,bal) + _ -> (Just (t, tmatched, numotheraccts > 1, acct, a, b), b) + where + a = signfn amt + b = bal + a + is = accountTransactionsReportItems query thisacctquery bal' signfn ts + +-- | Generate a short readable summary of some postings, like +-- "from (negatives) to (positives)". +summarisePostings :: [Posting] -> String +summarisePostings ps = + case (summarisePostingAccounts froms, summarisePostingAccounts tos) of + ("",t) -> "to "++t + (f,"") -> "from "++f + (f,t) -> "from "++f++" to "++t + where + (froms,tos) = partition (fromMaybe False . isNegativeMixedAmount . pamount) ps + +-- | Generate a simplified summary of some postings' accounts. +summarisePostingAccounts :: [Posting] -> String +summarisePostingAccounts = intercalate ", " . map accountLeafName . nub . map paccount + +filterTransactionPostings :: Query -> Transaction -> Transaction +filterTransactionPostings m t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps} + +------------------------------------------------------------------------------- + +-- | Split a transactions report whose items may involve several commodities, +-- into one or more single-commodity transactions reports. +transactionsReportByCommodity :: TransactionsReport -> [TransactionsReport] +transactionsReportByCommodity tr = + [filterTransactionsReportByCommodity c tr | c <- transactionsReportCommodities tr] + where + transactionsReportCommodities (_,items) = + nub $ sort $ map acommodity $ concatMap (amounts . triAmount) items + +-- Remove transaction report items and item amount (and running +-- balance amount) components that don't involve the specified +-- commodity. Other item fields such as the transaction are left unchanged. +filterTransactionsReportByCommodity :: Commodity -> TransactionsReport -> TransactionsReport +filterTransactionsReportByCommodity c (label,items) = + (label, fixTransactionsReportItemBalances $ concat [filterTransactionsReportItemByCommodity c i | i <- items]) + where + filterTransactionsReportItemByCommodity c (t,t2,s,o,a,bal) + | c `elem` cs = [item'] + | otherwise = [] + where + cs = map acommodity $ amounts a + item' = (t,t2,s,o,a',bal) + a' = filterMixedAmountByCommodity c a + + fixTransactionsReportItemBalances [] = [] + fixTransactionsReportItemBalances [i] = [i] + fixTransactionsReportItemBalances items = reverse $ i:(go startbal is) + where + i:is = reverse items + startbal = filterMixedAmountByCommodity c $ triBalance i + go _ [] = [] + go bal ((t,t2,s,o,amt,_):is) = (t,t2,s,o,amt,bal'):go bal' is + where bal' = bal + amt + +-- | Filter out all but the specified commodity from this amount. +filterMixedAmountByCommodity :: Commodity -> MixedAmount -> MixedAmount +filterMixedAmountByCommodity c (Mixed as) = Mixed $ filter ((==c). acommodity) as + +------------------------------------------------------------------------------- + diff --git a/Hledger/Utils.hs b/Hledger/Utils.hs --- a/Hledger/Utils.hs +++ b/Hledger/Utils.hs @@ -91,7 +91,7 @@ | last s == '\n' = s | otherwise = s ++ "\n" --- | Wrap a string in single quotes, and \-prefix any embedded single +-- | Wrap a string in double quotes, and \-prefix any embedded single -- quotes, if it contains whitespace and is not already single- or -- double-quoted. quoteIfSpaced :: String -> String @@ -99,6 +99,22 @@ | not $ any (`elem` s) whitespacechars = s | otherwise = "'"++escapeSingleQuotes s++"'" +-- | Double-quote this string if it contains whitespace, single quotes +-- or double-quotes, escaping the quotes as needed. +quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\"" + | otherwise = s + +-- | Single-quote this string if it contains whitespace or double-quotes. +-- No good for strings containing single quotes. +singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'" + | otherwise = s + +quotechars = "'\"" +whitespacechars = " \t\n\r" + +escapeDoubleQuotes :: String -> String +escapeDoubleQuotes = regexReplace "\"" "\"" + escapeSingleQuotes :: String -> String escapeSingleQuotes = regexReplace "'" "\'" @@ -111,21 +127,16 @@ words' "" = [] words' s = map stripquotes $ fromparse $ parsewith p s where - p = do ss <- (quotedPattern <|> pattern) `sepBy` many1 spacenonewline + p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` many1 spacenonewline -- eof return ss pattern = many (noneOf whitespacechars) - quotedPattern = between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\"" + singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'") + doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") -- | Quote-aware version of unwords - single-quote strings which contain whitespace 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 - -whitespacechars = " \t\n\r" +unwords' = unwords . map quoteIfNeeded -- | Strip one matching pair of single or double quotes on the ends of a string. stripquotes :: String -> String @@ -215,6 +226,23 @@ fit w = take w . (++ repeat ' ') blankline = replicate w ' ' +-- tuples + +first3 (x,_,_) = x +second3 (_,x,_) = x +third3 (_,_,x) = x + +first4 (x,_,_,_) = x +second4 (_,x,_,_) = x +third4 (_,_,x,_) = x +fourth4 (_,_,_,x) = x + +first5 (x,_,_,_,_) = x +second5 (_,x,_,_,_) = x +third5 (_,_,x,_,_) = x +fourth5 (_,_,_,x,_) = x +fifth5 (_,_,_,_,x) = x + -- math difforzero :: (Num a, Ord a) => a -> a -> a @@ -406,8 +434,25 @@ -- | Print a message and a showable value to the console if the global -- debug level is non-zero. Uses unsafePerformIO. dbg :: Show a => String -> a -> a -dbg = dbgppshow 1 +dbg = dbg1 +dbg0 :: Show a => String -> a -> a +dbg0 = dbgAt 0 + +dbg1 :: Show a => String -> a -> a +dbg1 = dbgAt 1 + +dbg2 :: Show a => String -> a -> a +dbg2 = dbgAt 2 + +-- | Print a message and a showable value to the console if the global +-- debug level is at or above the specified level. Uses unsafePerformIO. +dbgAt :: Show a => Int -> String -> a -> a +dbgAt lvl = dbgppshow lvl + +dbgAtM :: Show a => Int -> String -> a -> IO () +dbgAtM lvl lbl x = dbgAt lvl lbl x `seq` return () + -- | Print a showable value to the console, with a message, if the -- debug level is at or above the specified level (uses -- unsafePerformIO). @@ -423,8 +468,14 @@ -- Values are displayed with ppShow, each field/constructor on its own line. dbgppshow :: Show a => Int -> String -> a -> a dbgppshow level - | debugLevel >= level = \s -> traceWith (((s++": ")++) . ppShow) - | otherwise = flip const + | debugLevel < level = flip const + | otherwise = \s a -> let p = ppShow a + ls = lines p + nlorspace | length ls > 1 = "\n" + | otherwise = " " ++ take (10 - length s) (repeat ' ') + ls' | length ls > 1 = map (" "++) ls + | otherwise = ls + in trace (s++":"++nlorspace++intercalate "\n" ls') a -- -- | Print a showable value to the console, with a message, if the -- -- debug level is at or above the specified level (uses diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -1,7 +1,7 @@ name: hledger-lib -version: 0.22.2 -stability: beta -category: Finance +version: 0.23 +stability: stable +category: Finance, Console synopsis: Core data types, parsers and utilities for the hledger accounting tool. description: hledger is a library and set of user tools for working @@ -17,7 +17,7 @@ maintainer: Simon Michael homepage: http://hledger.org bug-reports: http://hledger.org/bugs -tested-with: GHC==7.2.2, GHC==7.4.2, GHC==7.6.3, GHC==7.8 +tested-with: GHC==7.2.2, GHC==7.4.2, GHC==7.6.3, GHC==7.8.2 cabal-version: >= 1.10 build-type: Simple -- data-dir: data @@ -42,10 +42,11 @@ Hledger.Data.Amount Hledger.Data.Commodity Hledger.Data.Dates - Hledger.Data.FormatStrings + Hledger.Data.OutputFormat Hledger.Data.Journal Hledger.Data.Ledger Hledger.Data.Posting + Hledger.Data.RawOptions Hledger.Data.TimeLog Hledger.Data.Transaction Hledger.Data.Types @@ -55,6 +56,13 @@ Hledger.Read.JournalReader Hledger.Read.TimelogReader Hledger.Reports + Hledger.Reports.ReportOptions + Hledger.Reports.BalanceHistoryReport + Hledger.Reports.BalanceReport + Hledger.Reports.EntriesReport + Hledger.Reports.MultiBalanceReports + Hledger.Reports.PostingsReport + Hledger.Reports.TransactionsReports Hledger.Utils Hledger.Utils.UTF8IOCompat build-depends: