diff --git a/Hledger/Data/Account.hs b/Hledger/Data/Account.hs --- a/Hledger/Data/Account.hs +++ b/Hledger/Data/Account.hs @@ -49,8 +49,8 @@ , aboring = False } --- | Derive an account tree with balances from a set of postings. --- (*ledger's core feature.) The accounts are returned in a list, but +-- | Derive 1. an account tree and 2. their balances from a list of postings. +-- (ledger's core feature). The accounts are returned in a list, but -- retain their tree structure; the first one is the root of the tree. accountsFromPostings :: [Posting] -> [Account] accountsFromPostings ps = @@ -58,10 +58,9 @@ acctamts = [(paccount p,pamount p) | p <- ps] grouped = groupBy (\a b -> fst a == fst b) $ sort $ acctamts summed = map (\as@((aname,_):_) -> (aname, sum $ map snd as)) grouped -- always non-empty - setebalance a = a{aebalance=lookupJustDef nullmixedamt (aname a) summed} nametree = treeFromPaths $ map (expandAccountName . fst) summed acctswithnames = nameTreeToAccount "root" nametree - acctswithebals = mapAccounts setebalance acctswithnames + acctswithebals = mapAccounts setebalance acctswithnames where setebalance a = a{aebalance=lookupJustDef nullmixedamt (aname a) summed} acctswithibals = sumAccounts acctswithebals acctswithparents = tieAccountParents acctswithibals acctsflattened = flattenAccounts acctswithparents @@ -101,9 +100,6 @@ | otherwise = any (anyAccounts p) $ asubs a -- | Add subaccount-inclusive balances to an account tree. --- -- , also noting --- -- whether it has an interesting balance or interesting subs to help --- -- with eliding later. sumAccounts :: Account -> Account sumAccounts a | null $ asubs a = a{aibalance=aebalance a} diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -115,7 +115,14 @@ ------------------------------------------------------------------------------- -- Amount -instance Show Amount where show = showAmountDebug +instance Show Amount where + show _a@Amount{..} + -- debugLevel < 3 = showAmountWithoutPrice a + -- debugLevel < 6 = showAmount a + | debugLevel < 9 = + 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) instance Num Amount where abs a@Amount{aquantity=q} = a{aquantity=abs q} @@ -229,11 +236,11 @@ withPrecision :: Amount -> Int -> Amount withPrecision = flip setAmountPrecision --- | Get the unambiguous string representation of an amount, for debugging. +-- | Get a string representation of an amount for debugging, +-- appropriate to the current debug level. 9 shows maximum detail. showAmountDebug :: Amount -> String showAmountDebug Amount{acommodity="AUTO"} = "(missing)" -showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice=%s, astyle=%s}" - (show acommodity) (show aquantity) (showPriceDebug aprice) (show astyle) +showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice=%s, astyle=%s}" (show acommodity) (show aquantity) (showPriceDebug aprice) (show astyle) -- | Get the string representation of an amount, without any \@ price. showAmountWithoutPrice :: Amount -> String @@ -323,7 +330,11 @@ ------------------------------------------------------------------------------- -- MixedAmount -instance Show MixedAmount where show = showMixedAmountDebug +instance Show MixedAmount where + show + -- debugLevel < 3 = intercalate "\\n" . lines . showMixedAmountWithoutPrice + -- debugLevel < 6 = intercalate "\\n" . lines . showMixedAmount + | otherwise = showMixedAmountDebug instance Num MixedAmount where fromInteger i = Mixed [fromInteger i] @@ -450,9 +461,9 @@ showMixedAmount :: MixedAmount -> String showMixedAmount m = vConcatRightAligned $ map showAmount $ amounts $ normaliseMixedAmountPreservingFirstPrice m --- | Compact labelled trace of a mixed amount. +-- | Compact labelled trace of a mixed amount, for debugging. ltraceamount :: String -> MixedAmount -> MixedAmount -ltraceamount s = tracewith (((s ++ ": ") ++).showMixedAmount) +ltraceamount s = traceWith (((s ++ ": ") ++).showMixedAmount) -- | Set the display precision in the amount's commodities. setMixedAmountPrecision :: Int -> MixedAmount -> MixedAmount diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -31,6 +31,7 @@ parsedateM, parsedate, showDate, + showDateSpan, elapsedSeconds, prevday, parsePeriodExpr, @@ -39,6 +40,9 @@ failIfInvalidYear, datesepchar, datesepchars, + spanStart, + spanEnd, + spansSpan, spanIntersect, spansIntersect, spanUnion, @@ -64,7 +68,7 @@ import Data.Time.Calendar.OrdinalDate import Data.Time.Clock import Data.Time.LocalTime -import Safe (readMay) +import Safe (headMay, lastMay, readMay) import System.Locale (defaultTimeLocale) import Test.HUnit import Text.ParserCombinators.Parsec @@ -77,6 +81,15 @@ showDate :: Day -> String showDate = formatTime defaultTimeLocale "%C%y/%m/%d" +showDateSpan (DateSpan from to) = + concat + [maybe "" showdate from + ,"-" + ,maybe "" (showdate . prevday) to + ] + where + showdate = formatTime defaultTimeLocale "%C%y/%m/%d" + -- | Get the current local date. getCurrentDay :: IO Day getCurrentDay = do @@ -98,6 +111,16 @@ elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a elapsedSeconds t1 = realToFrac . diffUTCTime t1 +spanStart :: DateSpan -> Maybe Day +spanStart (DateSpan d _) = d + +spanEnd :: DateSpan -> Maybe Day +spanEnd (DateSpan _ d) = d + +-- | 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. splitSpan :: Interval -> DateSpan -> [DateSpan] splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] @@ -144,7 +167,9 @@ 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. +-- 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 @@ -598,19 +623,27 @@ optional (string "from" >> many spacenonewline) b <- smartdate many spacenonewline - optional (string "to" >> many spacenonewline) + optional (choice [string "to", string "-"] >> many spacenonewline) e <- smartdate return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) fromdatespan :: Day -> GenParser Char st DateSpan fromdatespan rdate = do - string "from" >> many spacenonewline - b <- smartdate + b <- choice [ + do + string "from" >> many spacenonewline + smartdate + , + do + d <- smartdate + string "-" + return d + ] return $ DateSpan (Just $ fixSmartDate rdate b) Nothing todatespan :: Day -> GenParser Char st DateSpan todatespan rdate = do - string "to" >> many spacenonewline + choice [string "to", string "-"] >> many spacenonewline e <- smartdate return $ DateSpan Nothing (Just $ fixSmartDate rdate e) diff --git a/Hledger/Data/Journal.hs b/Hledger/Data/Journal.hs --- a/Hledger/Data/Journal.hs +++ b/Hledger/Data/Journal.hs @@ -76,7 +76,21 @@ instance Show Journal where - show j = printf "Journal %s with %d transactions, %d accounts: %s, commodity styles: %s" + show j + | debugLevel < 3 = printf "Journal %s with %d transactions, %d accounts" + (journalFilePath j) + (length (jtxns j) + + length (jmodifiertxns j) + + length (jperiodictxns j)) + (length accounts) + | debugLevel < 6 = printf "Journal %s with %d transactions, %d accounts: %s" + (journalFilePath j) + (length (jtxns j) + + length (jmodifiertxns j) + + length (jperiodictxns j)) + (length accounts) + (show accounts) + | otherwise = printf "Journal %s with %d transactions, %d accounts: %s, commodity styles: %s" (journalFilePath j) (length (jtxns j) + length (jmodifiertxns j) + diff --git a/Hledger/Data/Transaction.hs b/Hledger/Data/Transaction.hs --- a/Hledger/Data/Transaction.hs +++ b/Hledger/Data/Transaction.hs @@ -106,20 +106,18 @@ pstatus=True, paccount="a", pamount=Mixed [usd 1, hrs 2], - pcomment="pcomment1\npcomment2\n", + pcomment="\npcomment2\n", ptype=RegularPosting, ptags=[("ptag1","val1"),("ptag2","val2")] } ] } `gives` unlines [ - "2012/05/14=2012/05/15 (code) desc", - " ;tcomment1", - " ;tcomment2", + "2012/05/14=2012/05/15 (code) desc ; tcomment1", + " ; tcomment2", " $1.00", " * a 2.0h", - " ;pcomment1", - " ;pcomment2", + " ; pcomment2", "" ] ] @@ -128,30 +126,39 @@ showTransaction' :: Bool -> Transaction -> String showTransaction' elide t = unlines $ [descriptionline] - ++ multilinecomment + ++ newlinecomments ++ (postingsAsLines elide t (tpostings t)) ++ [""] where - descriptionline = rstrip $ concat [date, status, code, desc, inlinecomment] + descriptionline = rstrip $ concat [date, status, code, desc, samelinecomment] date = showdate (tdate t) ++ maybe "" showedate (tdate2 t) showdate = printf "%-10s" . showDate showedate = printf "=%s" . showdate status = if tstatus t then " *" else "" code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else "" desc = if null d then "" else " " ++ d where d = tdescription t - (inlinecomment, multilinecomment) = commentLines $ tcomment t + (samelinecomment, newlinecomments) = + case renderCommentLines (tcomment t) of [] -> ("",[]) + c:cs -> (c,cs) --- Render a transaction or posting's comment as indented, semicolon-prefixed comment lines - --- an inline comment (when it's a single line) or multiple lines. -commentLines :: String -> (String, [String]) -commentLines s - | null s = ("", []) - | length ls == 1 = (prefix $ head ls, []) - | otherwise = ("", (prefix $ head ls):(map prefix $ tail ls)) +-- Render a transaction or posting's comment as indented, semicolon-prefixed comment lines. +renderCommentLines :: String -> [String] +renderCommentLines s = case lines s of ("":ls) -> "":map commentprefix ls + ls -> map commentprefix ls where - ls = lines s - prefix = indent . (";"++) + commentprefix = indent . ("; "++) +-- -- Render a transaction or posting's comment as semicolon-prefixed comment lines - +-- -- an inline (same-line) comment if it's a single line, otherwise multiple indented lines. +-- commentLines' :: String -> (String, [String]) +-- commentLines' s +-- | null s = ("", []) +-- | length ls == 1 = (prefix $ head ls, []) +-- | otherwise = ("", (prefix $ head ls):(map prefix $ tail ls)) +-- where +-- ls = lines s +-- prefix = indent . (";"++) + postingsAsLines :: Bool -> Transaction -> [Posting] -> [String] postingsAsLines elide t ps | elide && length ps > 1 && isTransactionBalanced Nothing t -- imprecise balanced check @@ -161,11 +168,13 @@ postingAsLines :: Bool -> [Posting] -> Posting -> [String] postingAsLines elideamount ps p = postinglines - ++ multilinecomment + ++ newlinecomments where - postinglines = map rstrip $ lines $ concatTopPadded [showacct p, " ", amount, inlinecomment] + postinglines = map rstrip $ lines $ concatTopPadded [showacct p, " ", amount, samelinecomment] amount = if elideamount then "" else showamt (pamount p) - (inlinecomment, multilinecomment) = commentLines $ pcomment p + (samelinecomment, newlinecomments) = + case renderCommentLines (pcomment p) of [] -> ("",[]) + c:cs -> (c,cs) showacct p = indent $ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p)) where @@ -188,10 +197,9 @@ } `gives` [ " $1.00", - " * a 2.0h", - " ;pcomment1", - " ;pcomment2", - " ; tag3: val3 " + " * a 2.0h ; pcomment1", + " ; pcomment2", + " ; tag3: val3 " ] ] diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} {-| Most data types are defined here to avoid import cycles. @@ -20,28 +20,28 @@ module Hledger.Data.Types where import Control.Monad.Error (ErrorT) +import Data.Data import qualified Data.Map as M import Data.Time.Calendar import Data.Time.LocalTime -import Data.Typeable -import System.Time (ClockTime) +import System.Time (ClockTime(..)) type SmartDate = (String,String,String) data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show) -data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord) +data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord,Data,Typeable) data Interval = NoInterval | Days Int | Weeks Int | Months Int | Quarters Int | Years Int | DayOfMonth Int | DayOfWeek Int -- WeekOfYear Int | MonthOfYear Int | QuarterOfYear Int - deriving (Eq,Show,Ord) + deriving (Eq,Show,Ord,Data,Typeable) type AccountName = String -data Side = L | R deriving (Eq,Show,Read,Ord) +data Side = L | R deriving (Eq,Show,Read,Ord,Typeable,Data) type Commodity = String @@ -49,7 +49,7 @@ -- | An amount's price (none, per unit, or total) in another commodity. -- Note the price should be a positive number, although this is not enforced. -data Price = NoPrice | UnitPrice Amount | TotalPrice Amount deriving (Eq,Ord) +data Price = NoPrice | UnitPrice Amount | TotalPrice Amount deriving (Eq,Ord,Typeable,Data) -- | Display style for an amount. data AmountStyle = AmountStyle { @@ -59,21 +59,21 @@ asdecimalpoint :: Char, -- ^ character used as decimal point asseparator :: Char, -- ^ character used for separating digit groups (eg thousands) asseparatorpositions :: [Int] -- ^ positions of digit group separators, counting leftward from decimal point -} deriving (Eq,Ord,Show,Read) +} deriving (Eq,Ord,Read,Show,Typeable,Data) data Amount = Amount { acommodity :: Commodity, aquantity :: Quantity, aprice :: Price, -- ^ the (fixed) price for this amount, if any astyle :: AmountStyle - } deriving (Eq,Ord) + } deriving (Eq,Ord,Typeable,Data) -newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord) +newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Typeable,Data) data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting - deriving (Eq,Show) + deriving (Eq,Show,Typeable,Data) -type Tag = (String, String) +type Tag = (String, String) -- ^ A tag name and (possibly empty) value. data Posting = Posting { pdate :: Maybe Day, -- ^ this posting's date, if different from the transaction's @@ -81,13 +81,13 @@ pstatus :: Bool, paccount :: AccountName, pamount :: MixedAmount, - pcomment :: String, -- ^ this posting's non-tag comment lines, as a single non-indented string + pcomment :: String, -- ^ this posting's comment lines, as a single non-indented multi-line string ptype :: PostingType, - ptags :: [Tag], + ptags :: [Tag], -- ^ tag names and values, extracted from the comment pbalanceassertion :: Maybe MixedAmount, -- ^ optional: the expected balance in the account after this posting ptransaction :: Maybe Transaction -- ^ this posting's parent transaction (co-recursive types). -- Tying this knot gets tedious, Maybe makes it easier/optional. - } + } deriving (Typeable,Data) -- The equality test for postings ignores the parent transaction's -- identity, to avoid infinite loops. @@ -100,35 +100,35 @@ tstatus :: Bool, -- XXX tcleared ? tcode :: String, tdescription :: String, - tcomment :: String, -- ^ this transaction's non-tag comment lines, as a single non-indented string - ttags :: [Tag], + tcomment :: String, -- ^ this transaction's comment lines, as a single non-indented multi-line string + ttags :: [Tag], -- ^ tag names and values, extracted from the comment tpostings :: [Posting], -- ^ this transaction's postings - tpreceding_comment_lines :: String - } deriving (Eq) + tpreceding_comment_lines :: String -- ^ any comment lines immediately preceding this transaction + } deriving (Eq,Typeable,Data) data ModifierTransaction = ModifierTransaction { mtvalueexpr :: String, mtpostings :: [Posting] - } deriving (Eq) + } deriving (Eq,Typeable,Data) data PeriodicTransaction = PeriodicTransaction { ptperiodicexpr :: String, ptpostings :: [Posting] - } deriving (Eq) + } deriving (Eq,Typeable,Data) -data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord) +data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Typeable,Data) data TimeLogEntry = TimeLogEntry { tlcode :: TimeLogCode, tldatetime :: LocalTime, tlcomment :: String - } deriving (Eq,Ord) + } deriving (Eq,Ord,Typeable,Data) data HistoricalPrice = HistoricalPrice { hdate :: Day, hcommodity :: Commodity, hamount :: Amount - } deriving (Eq) -- & Show (in Amount.hs) + } deriving (Eq,Typeable,Data) -- & Show (in Amount.hs) type Year = Integer @@ -143,8 +143,11 @@ -- specified with "account" directive(s). Concatenated, these -- are the account prefix prepended to parsed account names. , ctxAliases :: ![(AccountName,AccountName)] -- ^ the current list of account name aliases in effect - } deriving (Read, Show, Eq) + } deriving (Read, Show, Eq, Data, Typeable) +deriving instance Data (ClockTime) +deriving instance Typeable (ClockTime) + data Journal = Journal { jmodifiertxns :: [ModifierTransaction], jperiodictxns :: [PeriodicTransaction], @@ -159,7 +162,7 @@ -- order encountered (XXX reversed, cf journalAddFile). filereadtime :: ClockTime, -- ^ when this journal was last read from its file(s) jcommoditystyles :: M.Map Commodity AmountStyle -- ^ how to display amounts in each commodity - } deriving (Eq, Typeable) + } deriving (Eq, Typeable, Data) -- | A JournalUpdate is some transformation of a Journal. It can do I/O or -- raise an error. diff --git a/Hledger/Query.hs b/Hledger/Query.hs --- a/Hledger/Query.hs +++ b/Hledger/Query.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-| A general query system for matching things (accounts, postings, @@ -32,6 +33,7 @@ tests_Hledger_Query ) where +import Data.Data import Data.Either import Data.List import Data.Maybe @@ -43,7 +45,7 @@ import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName -import Hledger.Data.Amount (nullamt) +import Hledger.Data.Amount (amount, usd) import Hledger.Data.Dates import Hledger.Data.Posting import Hledger.Data.Transaction @@ -64,19 +66,40 @@ | 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 + | 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 ? | Depth Int -- ^ match if account depth is less than or equal to this value | Tag String (Maybe String) -- ^ match if a tag with this exact name, and with value -- matching the regexp if provided, exists - deriving (Show, Eq) + deriving (Eq,Data,Typeable) +-- custom Show implementation to show strings more accurately, eg for debugging regexps +instance Show Query where + show Any = "Any" + show None = "None" + show (Not q) = "Not (" ++ show q ++ ")" + show (Or qs) = "Or (" ++ show qs ++ ")" + show (And qs) = "And (" ++ show qs ++ ")" + show (Code r) = "Code " ++ show r + show (Desc r) = "Desc " ++ show r + show (Acct r) = "Acct " ++ show r + show (Date ds) = "Date (" ++ show ds ++ ")" + show (Date2 ds) = "Date2 (" ++ show ds ++ ")" + show (Status b) = "Status " ++ show b + show (Real b) = "Real " ++ show b + show (Amt ord qty) = "Amt " ++ show ord ++ " " ++ show qty + show (Sym r) = "Sym " ++ show r + show (Empty b) = "Empty " ++ show b + show (Depth n) = "Depth " ++ show n + show (Tag s ms) = "Tag " ++ show s ++ " (" ++ show ms ++ ")" + -- | A query option changes a query's/report's behaviour and output in some way. data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register focussed on this account | QueryOptInAcct AccountName -- ^ as above but include sub-accounts in the account register -- | QueryOptCostBasis -- ^ show amounts converted to cost where possible -- | QueryOptDate2 -- ^ show secondary dates instead of primary dates - deriving (Show, Eq) + deriving (Show, Eq, Data, Typeable) -- parsing @@ -174,12 +197,14 @@ prefixes = map (++":") [ "inacctonly" ,"inacct" + ,"amt" ,"code" ,"desc" ,"acct" ,"date" ,"edate" ,"status" + ,"sym" ,"real" ,"empty" ,"depth" @@ -216,9 +241,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) = parseAmountTest s +parseQueryTerm _ ('a':'m':'t':':':s) = Left $ Amt op q where (op, 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 _ ('t':'a':'g':':':s) = Left $ Tag n v where (n,v) = parseTag s parseQueryTerm _ "" = Left $ Any parseQueryTerm d s = parseQueryTerm d $ defaultprefix++":"++s @@ -244,21 +270,23 @@ ] -- can fail -parseAmountTest :: String -> (Ordering, Quantity) -parseAmountTest s = +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') - _ -> err - where err = error' $ "could not parse as operator followed by numeric quantity: "++s + s' -> (EQ, readDef err s') + where + err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a numeric quantity: " ++ s -tests_parseAmountTest = [ - "parseAmountTest" ~: do - let s `gives` r = parseAmountTest s `is` r +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) ] @@ -509,6 +537,7 @@ -- matchesPosting (Empty False) Posting{pamount=a} = True -- matchesPosting (Empty True) Posting{pamount=a} = isZeroMixedAmount a matchesPosting (Empty _) _ = True +matchesPosting (Sym r) Posting{pamount=Mixed as} = any (regexMatchesCI $ "^" ++ r ++ "$") $ map acommodity as matchesPosting (Tag n Nothing) p = isJust $ lookupTagByName n $ postingAllTags p matchesPosting (Tag n (Just v)) p = isJust $ lookupTagByNameAndValue (n,v) $ postingAllTags p -- matchesPosting _ _ = False @@ -516,7 +545,7 @@ -- | 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 [nullamt]) +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 @@ -537,16 +566,20 @@ assertBool "real:1 on real posting" $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting} assertBool "real:1 on virtual posting fails" $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting} assertBool "real:1 on balanced virtual posting fails" $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting} - assertBool "" $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"} - assertBool "" $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting - assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]} - assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]} - assertBool "" $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} - assertBool "" $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]} - assertBool "" $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} - assertBool "" $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]} + assertBool "a" $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"} + assertBool "b" $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting + assertBool "c" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]} + assertBool "d" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]} + assertBool "e" $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} + assertBool "f" $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]} + assertBool "g" $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} + assertBool "h" $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]} -- a tag match on a posting also sees inherited tags - assertBool "" $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}} + assertBool "i" $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}} + assertBool "j" $ not $ (Sym "$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol + assertBool "k" $ (Sym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr + assertBool "l" $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [amount{acommodity="shekels"}]} + assertBool "m" $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [amount{acommodity="shekels"}]} ] -- | Does the match expression match this transaction ? @@ -566,6 +599,7 @@ matchesTransaction q@(Amt _ _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction (Empty _) _ = True matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t +matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction (Tag n Nothing) t = isJust $ lookupTagByName n $ transactionAllTags t matchesTransaction (Tag n (Just v)) t = isJust $ lookupTagByNameAndValue (n,v) $ transactionAllTags t @@ -603,7 +637,7 @@ ++ tests_words'' ++ tests_filterQuery ++ tests_parseQueryTerm - ++ tests_parseAmountTest + ++ tests_parseAmountQueryTerm ++ tests_parseQuery ++ tests_matchesAccount ++ tests_matchesPosting diff --git a/Hledger/Read/CsvReader.hs b/Hledger/Read/CsvReader.hs --- a/Hledger/Read/CsvReader.hs +++ b/Hledger/Read/CsvReader.hs @@ -22,7 +22,7 @@ import Control.Monad import Control.Monad.Error -- import Test.HUnit -import Data.Char (toLower, isDigit) +import Data.Char (toLower, isDigit, isSpace) import Data.List import Data.Maybe import Data.Ord @@ -85,7 +85,7 @@ -- parse csv records <- (either throwerr id . validateCsv) `fmap` parseCsv csvfile csvdata - dbg 1 $ ppShow $ take 3 records + return $ dbg "" $ take 3 records -- identify header lines -- let (headerlines, datalines) = identifyHeaderLines records @@ -98,7 +98,7 @@ then hPrintf stderr "creating default conversion rules file %s, edit this file for better results\n" rulesfile else hPrintf stderr "using conversion rules file %s\n" rulesfile rules <- either (throwerr.show) id `fmap` parseRulesFile rulesfile - dbg 1 $ ppShow rules + return $ dbg "" rules -- apply skip directive let headerlines = maybe 0 oneorerror $ getDirective "skip" rules @@ -319,7 +319,7 @@ parseRulesFile :: FilePath -> IO (Either ParseError CsvRules) parseRulesFile f = do - s <- readFile' f + s <- readFile' f >>= expandIncludes let rules = parseCsvRules f s return $ case rules of Left e -> Left e @@ -328,6 +328,19 @@ Right r -> Right r where toParseError s = newErrorMessage (Message s) (initialPos "") + +-- | Pre-parse csv rules to interpolate included files, recursively. +-- This is a cheap hack to avoid rewriting the existing parser. +expandIncludes :: String -> IO String +expandIncludes s = do + let (ls,rest) = break (isPrefixOf "include") $ lines s + case rest of + [] -> return $ unlines ls + (('i':'n':'c':'l':'u':'d':'e':f):ls') -> do + let f' = dropWhile isSpace f + included <- readFile f' >>= expandIncludes + return $ unlines [unlines ls, included, unlines ls'] + ls' -> return $ unlines $ ls ++ ls' -- should never get here parseCsvRules :: FilePath -> String -> Either ParseError CsvRules -- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs --- a/Hledger/Read/JournalReader.hs +++ b/Hledger/Read/JournalReader.hs @@ -817,19 +817,15 @@ followingcomment :: GenParser Char JournalContext String followingcomment = -- ptrace "followingcomment" - (do first <- many spacenonewline >> followingcommentline - rest <- many (try (many1 spacenonewline >> followingcommentline)) - return $ unlines $ first:rest - ) <|> - do - many spacenonewline >> newline - rest <- many (try (many1 spacenonewline >> followingcommentline)) - return $ unlines rest + do samelinecomment <- many spacenonewline >> (try commentline <|> (newline >> return "")) + newlinecomments <- many (try (many1 spacenonewline >> commentline)) + return $ unlines $ samelinecomment:newlinecomments -followingcommentline :: GenParser Char JournalContext String -followingcommentline = do - -- ptrace "followingcommentline" +commentline :: GenParser Char JournalContext String +commentline = do + -- ptrace "commentline" char ';' + many spacenonewline l <- anyChar `manyTill` eolof optional newline return l diff --git a/Hledger/Reports.hs b/Hledger/Reports.hs --- a/Hledger/Reports.hs +++ b/Hledger/Reports.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} {-| Generate several common kinds of report from a journal, as \"*Report\" - simple intermediate data structures intended to be easily rendered as text, html, json, csv etc. by hledger commands, hamlet templates, -javascript, or whatever. This is under Hledger.Cli since it depends -on the command-line options, should move to hledger-lib later. +javascript, or whatever. -} module Hledger.Reports ( + -- * Report options + -- | ReportOpts(..), + BalanceType(..), DisplayExp, FormatStr, defreportopts, @@ -21,16 +23,20 @@ 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, @@ -39,12 +45,25 @@ transactionsReportByCommodity, journalTransactionsReport, accountTransactionsReport, - -- * Accounts report - AccountsReport, - AccountsReportItem, - accountsReport, - -- * Other "reports" + + -- * 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 ) @@ -68,6 +87,9 @@ 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. @@ -80,10 +102,11 @@ ,cost_ :: Bool ,depth_ :: Maybe Int ,display_ :: Maybe DisplayExp - ,date2_ :: Bool + ,date2_ :: Bool ,empty_ :: Bool ,no_elide_ :: Bool ,real_ :: Bool + ,balancetype_ :: BalanceType -- for balance command ,flat_ :: Bool -- for balance command ,drop_ :: Int -- " ,no_total_ :: Bool -- " @@ -94,12 +117,20 @@ ,yearly_ :: Bool ,format_ :: Maybe FormatStr ,related_ :: Bool + ,average_ :: Bool ,query_ :: String -- all arguments, as a string - } deriving (Show) + } 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 @@ -124,6 +155,8 @@ def def def + def + def instance Default ReportOpts where def = defreportopts @@ -224,8 +257,8 @@ ------------------------------------------------------------------------------- -- | A journal entries report is a list of whole transactions as --- originally entered in the journal (mostly). Used by eg hledger's print --- command and hledger-web's journal entries view. +-- 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 @@ -248,20 +281,21 @@ -- | 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 + ,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 (+)) + (totallabel, postingsReportItems ps nullposting wd depth startbal runningcalcfn 1) where ps | interval == NoInterval = displayableps | otherwise = summarisePostingsByInterval interval depth empty reportspan displayableps @@ -273,8 +307,8 @@ $ dbg "ps3" $ (if related_ opts then concatMap relatedPostings else id) $ dbg "ps2" $ filter (q' `matchesPosting`) $ dbg "ps1" $ journalPostings j' - dbg :: Show a => String -> a -> a - dbg = flip const + -- enable to debug just this function + -- dbg :: Show a => String -> a -> a -- dbg = lstrace empty = queryEmpty q @@ -293,14 +327,16 @@ 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 -> (MixedAmount -> MixedAmount -> MixedAmount) -> [PostingsReportItem] -postingsReportItems [] _ _ _ _ _ = [] -postingsReportItems (p:ps) pprev wd d b sumfn = i:(postingsReportItems ps p wd d b' sumfn) +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 @@ -309,7 +345,7 @@ isdifferentdate = case wd of PrimaryDate -> postingDate p /= postingDate pprev SecondaryDate -> postingDate2 p /= postingDate2 pprev p' = p{paccount=clipAccountName d $ paccount p} - b' = b `sumfn` pamount 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 @@ -425,6 +461,8 @@ -- 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 ) @@ -480,11 +518,9 @@ filterMixedAmountByCommodity :: Commodity -> MixedAmount -> MixedAmount filterMixedAmountByCommodity c (Mixed as) = Mixed $ filter ((==c). acommodity) as --- | Select transactions from the whole journal for a transactions report, --- with no \"current\" account. The end result is similar to --- "postingsReport" except it uses queries and transaction-based report --- items and the items are most recent first. Used by eg hledger-web's --- journal view. +-- | 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 @@ -494,7 +530,7 @@ ------------------------------------------------------------------------------- --- | Select transactions within one or more \"current\" accounts, and make a +-- | 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). @@ -505,9 +541,9 @@ -- shows the accurate historical running balance for the current account(s). -- Otherwise it shows a running total starting at 0. -- --- Currently, reporting intervals are not supported, and report items are --- most recent first. Used by eg hledger-web's account register view. --- +-- 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 @@ -577,21 +613,28 @@ ------------------------------------------------------------------------------- --- | An accounts report is a list of account names (full and short --- variants) with their balances, appropriate indentation for rendering as --- a hierarchy, and grand total. -type AccountsReport = ([AccountsReportItem] -- line items, one per account +-- | 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 ) -type AccountsReportItem = (AccountName -- full account name - ,AccountName -- short account name for display (the leaf name, prefixed by any boring parents immediately above) - ,Int -- how many steps to indent this account (0 with --flat, otherwise the 0-based account depth excluding boring parents) - ,MixedAmount) -- account balance, includes subs unless --flat is present +-- | * 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. -accountsReport :: ReportOpts -> Query -> Journal -> AccountsReport -accountsReport opts q j = (items, total) +balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport +balanceReport opts q j = (items, total) where l = ledgerFromJournal q $ journalSelectingAmountFromOpts opts j accts = clipAccounts (queryDepth q) $ ledgerRootAccount l @@ -605,8 +648,9 @@ | otherwise = fromMaybe nullacct . pruneAccounts (isZeroMixedAmount.aibalance) markboring | no_elide_ opts = id | otherwise = markBoringParentAccounts - items = map (accountsReportItem opts) accts' + 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 @@ -617,8 +661,8 @@ mark a | length (asubs a) == 1 && isZeroMixedAmount (aebalance a) = a{aboring=True} | otherwise = a -accountsReportItem :: ReportOpts -> Account -> AccountsReportItem -accountsReportItem opts a@Account{aname=name, aibalance=ibal} +balanceReportItem :: ReportOpts -> Account -> BalanceReportItem +balanceReportItem opts a@Account{aname=name, aibalance=ibal} | flat_ opts = (name, name, 0, ibal) | otherwise = (name, elidedname, indent, ibal) where @@ -630,6 +674,171 @@ ------------------------------------------------------------------------------- +-- | 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 @@ -811,20 +1020,20 @@ -} ] -tests_accountsReport = +tests_balanceReport = let (opts,journal) `gives` r = do let (eitems, etotal) = r - (aitems, atotal) = accountsReport opts (queryFromOpts nulldate opts) journal + (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 [ - "accountsReport with no args on null journal" ~: do + "balanceReport with no args on null journal" ~: do (defreportopts, nulljournal) `gives` ([], Mixed [nullamt]) - ,"accountsReport with no args on sample journal" ~: do + ,"balanceReport with no args on sample journal" ~: do (defreportopts, samplejournal) `gives` ([ ("assets","assets",0, mamountp' "$-1.00") @@ -840,7 +1049,7 @@ ], Mixed [nullamt]) - ,"accountsReport with --depth=N" ~: do + ,"balanceReport with --depth=N" ~: do (defreportopts{depth_=Just 1}, samplejournal) `gives` ([ ("assets", "assets", 0, mamountp' "$-1.00") @@ -850,7 +1059,7 @@ ], Mixed [nullamt]) - ,"accountsReport with depth:N" ~: do + ,"balanceReport with depth:N" ~: do (defreportopts{query_="depth:1"}, samplejournal) `gives` ([ ("assets", "assets", 0, mamountp' "$-1.00") @@ -860,7 +1069,7 @@ ], Mixed [nullamt]) - ,"accountsReport with a date or secondary date span" ~: do + ,"balanceReport with a date or secondary date span" ~: do (defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives` ([], Mixed [nullamt]) @@ -871,7 +1080,7 @@ ], Mixed [nullamt]) - ,"accountsReport with desc:" ~: do + ,"balanceReport with desc:" ~: do (defreportopts{query_="desc:income"}, samplejournal) `gives` ([ ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00") @@ -879,7 +1088,7 @@ ], Mixed [nullamt]) - ,"accountsReport with not:desc:" ~: do + ,"balanceReport with not:desc:" ~: do (defreportopts{query_="not:desc:income"}, samplejournal) `gives` ([ ("assets","assets",0, mamountp' "$-2.00") @@ -1003,7 +1212,7 @@ ," c:d " ]) >>= either error' return let j' = journalCanonicaliseAmounts $ journalConvertAmountsToCost j -- enable cost basis adjustment - accountsReportAsText defreportopts (accountsReport defreportopts Any j') `is` + balanceReportAsText defreportopts (balanceReport defreportopts Any j') `is` [" $500 a:b" ," $-500 c:d" ,"--------------------" @@ -1048,7 +1257,7 @@ ++ tests_summarisePostingsByInterval ++ tests_postingsReport -- ++ tests_isInterestingIndented - ++ tests_accountsReport + ++ tests_balanceReport ++ [ -- ,"summarisePostingsInDateSpan" ~: do -- let gives (b,e,depth,showempty,ps) = diff --git a/Hledger/Utils.hs b/Hledger/Utils.hs --- a/Hledger/Utils.hs +++ b/Hledger/Utils.hs @@ -21,6 +21,7 @@ ---- all of this one: module Hledger.Utils, Debug.Trace.trace, + module Data.PPrint, -- module Hledger.Utils.UTF8IOCompat SystemString,fromSystemString,toSystemString,error',userError', ppShow @@ -31,16 +32,22 @@ import Control.Monad.Error (MonadIO) import Control.Monad.IO.Class (liftIO) import Data.Char +import Data.Data import Data.List import qualified Data.Map as M import Data.Maybe +import Data.PPrint import Data.Time.Clock import Data.Time.LocalTime import Data.Tree import Debug.Trace +import Safe (readDef) import System.Directory (getHomeDirectory) +import System.Environment (getArgs) +import System.Exit import System.FilePath((), isRelative) import System.IO +import System.IO.Unsafe (unsafePerformIO) import Test.HUnit import Text.ParserCombinators.Parsec import Text.Printf @@ -339,25 +346,25 @@ -- http://hackage.haskell.org/packages/archive/htrace/0.1/doc/html/Debug-HTrace.html -- http://hackage.haskell.org/packages/archive/traced/2009.7.20/doc/html/Debug-Traced.html --- | trace (print on stdout at runtime) a showable expression +-- | Trace (print on stdout at runtime) a showable value. -- (for easily tracing in the middle of a complex expression) strace :: Show a => a -> a strace a = trace (show a) a --- | labelled trace showable - like strace, with a label prepended -lstrace :: Show a => String -> a -> a -lstrace l a = trace (l ++ ": " ++ show a) a +-- | Labelled trace - like strace, with a label prepended. +ltrace :: Show a => String -> a -> a +ltrace l a = trace (l ++ ": " ++ show a) a --- | monadic trace - like strace, but works as a standalone line in a monad +-- | Monadic trace - like strace, but works as a standalone line in a monad. mtrace :: (Monad m, Show a) => a -> m a mtrace a = strace a `seq` return a --- | trace an expression using a custom show function -tracewith :: (a -> String) -> a -> a -tracewith f e = trace (f e) e +-- | Custom trace - like strace, with a custom show function. +traceWith :: (a -> String) -> a -> a +traceWith f e = trace (f e) e -- | Parsec trace - show the current parsec position and next input, --- and the provided string if it's non-null. +-- and the provided label if it's non-null. ptrace :: String -> GenParser Char st () ptrace msg = do pos <- getPosition @@ -369,17 +376,72 @@ where peeklength = 30 -debugLevel = 0 +-- | Global debug level, which controls the verbosity of debug output +-- on the console. The default is 0 meaning no debug output. The +-- @--debug@ command line flag sets it to 1, or @--debug=N@ sets it to +-- a higher value (note: not @--debug N@ for some reason). This uses +-- unsafePerformIO and can be accessed from anywhere and before normal +-- command-line processing. After command-line processing, it is also +-- available as the @debug_@ field of 'Hledger.Cli.Options.CliOpts'. +debugLevel :: Int +debugLevel = case snd $ break (=="--debug") args of + "--debug":[] -> 1 + "--debug":n:_ -> readDef 1 n + _ -> + case take 1 $ filter ("--debug" `isPrefixOf`) args of + ['-':'-':'d':'e':'b':'u':'g':'=':v] -> readDef 1 v + _ -> 0 --- | Print a message to the console if the global debugLevel is --- greater than the level we are called with. -dbg :: Monad m => Float -> String -> m () -dbg level msg = when (level <= debugLevel) $ trace msg $ return () + where + args = unsafePerformIO getArgs --- | Print a message and parsec position info to the console if the --- global debugLevel is greater than the level we are called with. --- pdbg :: GenParser m => Float -> String -> m () +-- | 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 + +-- | Print a showable value to the console, with a message, if the +-- debug level is at or above the specified level (uses +-- unsafePerformIO). +-- Values are displayed with show, all on one line, which is hard to read. +dbgshow :: Show a => Int -> String -> a -> a +dbgshow level + | debugLevel >= level = ltrace + | otherwise = flip const + +-- | Print a showable value to the console, with a message, if the +-- debug level is at or above the specified level (uses +-- unsafePerformIO). +-- Values are displayed with ppShow, each field/constructor on its own line. +dbgppshow :: Show a => Int -> String -> a -> a +dbgppshow level + | debugLevel >= level = \s -> traceWith (((s++": ")++) . ppShow) + | otherwise = flip const + +-- | Print a showable value to the console, with a message, if the +-- debug level is at or above the specified level (uses +-- unsafePerformIO). +-- Values are displayed with pprint. Field names are not shown, but the +-- output is compact with smart line wrapping, long data elided, +-- and slow calculations timed out. +dbgpprint :: Data a => Int -> String -> a -> a +dbgpprint level msg a + | debugLevel >= level = unsafePerformIO $ do + pprint a >>= putStrLn . ((msg++": \n") ++) . show + return a + | otherwise = a + + +-- | Like dbg, then exit the program. Uses unsafePerformIO. +dbgExit :: Show a => String -> a -> a +dbgExit msg = const (unsafePerformIO exitFailure) . dbg msg + +-- | Print a message and parsec debug info (parse position and next +-- input) to the console when the debug level is at or above +-- this level. Uses unsafePerformIO. +-- pdbgAt :: GenParser m => Float -> String -> m () pdbg level msg = when (level <= debugLevel) $ ptrace msg + -- parsing diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -1,5 +1,6 @@ name: hledger-lib -version: 0.21.3 +version: 0.22 +stability: beta category: Finance synopsis: Core data types, parsers and utilities for the hledger accounting tool. description: @@ -16,8 +17,7 @@ maintainer: Simon Michael homepage: http://hledger.org bug-reports: http://hledger.org/bugs -stability: beta -tested-with: GHC==7.2.2, GHC==7.4.2, GHC==7.6.1 +tested-with: GHC==7.4.2, GHC==7.6.3 cabal-version: >= 1.10 build-type: Simple -- data-dir: data @@ -54,12 +54,13 @@ Hledger.Reports Hledger.Utils Hledger.Utils.UTF8IOCompat - Build-Depends: + build-depends: base >= 4.3 && < 5 ,bytestring ,cmdargs >= 0.10 && < 0.11 ,containers ,csv + ,data-pprint >= 0.2.3 && < 0.3 ,directory ,filepath ,mtl @@ -67,7 +68,7 @@ ,old-time ,parsec ,pretty-show - ,regex-compat == 0.95.* + ,regex-compat-tdfa == 0.95.* ,regexpr >= 0.5.1 ,safe >= 0.2 ,split >= 0.1 && < 0.3 @@ -90,6 +91,7 @@ , cmdargs , containers , csv + , data-pprint >= 0.2.3 && < 0.3 , directory , filepath , HUnit @@ -98,7 +100,7 @@ , old-time , parsec , pretty-show - , regex-compat + , regex-compat-tdfa , regexpr , safe , split