From 41a3fb91d52b85bf750c5cda1a9b9bb76b09ffdb Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Wed, 3 Dec 2008 23:20:38 +0000 Subject: [PATCH] support reporting intervals in period expressions and register report, and -W/-M/-D --- Ledger/Dates.hs | 115 ++++++++++++++++++++++++++++++++++++++------- Ledger/Ledger.hs | 8 ++++ Ledger/Types.hs | 3 ++ NOTES | 34 ++++---------- Options.hs | 53 ++++++++++++++++----- README | 8 +++- RegisterCommand.hs | 95 +++++++++++++++++++++++++++++-------- Tests.hs | 55 +++++++++++++++++++--- 8 files changed, 290 insertions(+), 81 deletions(-) diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs index 07cfc08ee..bbc81da4d 100644 --- a/Ledger/Dates.hs +++ b/Ledger/Dates.hs @@ -8,8 +8,11 @@ We represent these as a triple of strings like ("2008","12",""), ("","","tomorrow"), ("","last","week"). A 'DateSpan' is the span of time between two specific calendar dates, or -possibly an open-ended span where one or both dates are missing. We use -this term since "period" and "interval" are ambiguous. +an open-ended span where one or both dates are unspecified. (A date span +with both ends unspecified matches all dates.) + +An 'Interval' is ledger's "reporting interval" - weekly, monthly, +quarterly, etc. -} @@ -53,10 +56,32 @@ elapsedSeconds t1 t2 = realToFrac $ diffUTCTime t1 t2 dayToUTC :: Day -> UTCTime dayToUTC d = localTimeToUTC utc (LocalTime d midnight) --- | Convert a period expression to a date span using the provided reference date. -spanFromPeriodExpr refdate = fromparse . parsewith (periodexpr refdate) +-- | Split a DateSpan into one or more consecutive spans at the specified interval. +splitSpan :: Interval -> DateSpan -> [DateSpan] +splitSpan i (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] +splitSpan NoInterval s = [s] +splitSpan Daily s = splitspan start next s where (start,next) = (startofday,nextday) +splitSpan Weekly s = splitspan start next s where (start,next) = (startofweek,nextweek) +splitSpan Monthly s = splitspan start next s where (start,next) = (startofmonth,nextmonth) +splitSpan Quarterly s = splitspan start next s where (start,next) = (startofquarter,nextquarter) +splitSpan Yearly s = splitspan start next s where (start,next) = (startofyear,nextyear) + +splitspan _ _ (DateSpan Nothing Nothing) = [] +splitspan startof next (DateSpan Nothing (Just e)) = [DateSpan (Just $ startof e) (Just $ next $ startof e)] +splitspan startof next (DateSpan (Just b) Nothing) = [DateSpan (Just $ startof b) (Just $ next $ startof b)] +splitspan startof next (DateSpan (Just b) (Just e)) + | b >= e = [] + | otherwise = [DateSpan (Just $ startof b) (Just $ next $ startof b)] + ++ splitspan startof next (DateSpan (Just $ next $ startof b) (Just e)) --- | Convert a smart date string to a date span using the provided reference date. +-- | Parse a period expression to an Interval and overall DateSpan using +-- the provided reference date. +parsePeriodExpr :: Day -> String -> (Interval, DateSpan) +parsePeriodExpr refdate expr = (interval,span) + where (interval,span) = fromparse $ parsewith (periodexpr refdate) expr + +-- | Convert a single smart date string to a date span using the provided +-- reference date. spanFromSmartDateString :: Day -> String -> DateSpan spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate where @@ -135,6 +160,7 @@ fixSmartDate refdate sdate = fix sdate prevday :: Day -> Day prevday = addDays (-1) nextday = addDays 1 +startofday = id thisweek = startofweek prevweek = startofweek . addDays (-7) @@ -292,21 +318,78 @@ lastthisnextthing = do ] return ("",r,p) -periodexpr :: Day -> Parser DateSpan -periodexpr rdate = try (doubledateperiod rdate) <|> (singledateperiod rdate) +periodexpr :: Day -> Parser (Interval, DateSpan) +periodexpr rdate = choice $ map try [ + intervalanddateperiodexpr rdate, + intervalperiodexpr, + dateperiodexpr rdate, + (return $ (NoInterval,DateSpan Nothing Nothing)) + ] -doubledateperiod :: Day -> Parser DateSpan -doubledateperiod rdate = do - string "from" +intervalanddateperiodexpr :: Day -> Parser (Interval, DateSpan) +intervalanddateperiodexpr rdate = do many spacenonewline + i <- periodexprinterval + many spacenonewline + s <- periodexprdatespan rdate + return (i,s) + +intervalperiodexpr :: Parser (Interval, DateSpan) +intervalperiodexpr = do + many spacenonewline + i <- periodexprinterval + return (i, DateSpan Nothing Nothing) + +dateperiodexpr :: Day -> Parser (Interval, DateSpan) +dateperiodexpr rdate = do + many spacenonewline + s <- periodexprdatespan rdate + return (NoInterval, s) + +periodexprinterval :: Parser Interval +periodexprinterval = + choice $ map try [ + tryinterval "day" "daily" Daily, + tryinterval "week" "weekly" Weekly, + tryinterval "month" "monthly" Monthly, + tryinterval "quarter" "quarterly" Quarterly, + tryinterval "year" "yearly" Yearly + ] + where + tryinterval s1 s2 v = + choice [try (string $ "every "++s1), try (string s2)] >> return v + +periodexprdatespan :: Day -> Parser DateSpan +periodexprdatespan rdate = choice $ map try [ + doubledatespan rdate, + fromdatespan rdate, + todatespan rdate, + justdatespan rdate + ] + +doubledatespan :: Day -> Parser DateSpan +doubledatespan rdate = do + optional (string "from" >> many spacenonewline) b <- smartdate many spacenonewline - string "to" - many spacenonewline + optional (string "to" >> many spacenonewline) e <- smartdate - let span = DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) - return span + return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) -singledateperiod :: Day -> Parser DateSpan -singledateperiod rdate = smartdate >>= return . spanFromSmartDate rdate +fromdatespan :: Day -> Parser DateSpan +fromdatespan rdate = do + string "from" >> many spacenonewline + b <- smartdate + return $ DateSpan (Just $ fixSmartDate rdate b) Nothing +todatespan :: Day -> Parser DateSpan +todatespan rdate = do + string "to" >> many spacenonewline + e <- smartdate + return $ DateSpan Nothing (Just $ fixSmartDate rdate e) + +justdatespan :: Day -> Parser DateSpan +justdatespan rdate = do + optional (string "in" >> many spacenonewline) + d <- smartdate + return $ spanFromSmartDate rdate d diff --git a/Ledger/Ledger.hs b/Ledger/Ledger.hs index 8e49b07e4..0057e0f61 100644 --- a/Ledger/Ledger.hs +++ b/Ledger/Ledger.hs @@ -87,3 +87,11 @@ ledgerAccountTree depth l = treemap (ledgerAccount l) $ treeprune depth $ accoun -- | Get a ledger's tree of accounts rooted at the specified account. ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account) ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l + +-- | The (explicit) date span containing all the ledger's transactions, +-- or DateSpan Nothing Nothing if there are no transactions. +ledgerDateSpan l + | null ts = DateSpan Nothing Nothing + | otherwise = DateSpan (Just $ date $ head ts) (Just $ date $ last ts) + where + ts = sortBy (comparing date) $ ledgerTransactions l diff --git a/Ledger/Types.hs b/Ledger/Types.hs index 7bad37bdc..cac146f24 100644 --- a/Ledger/Types.hs +++ b/Ledger/Types.hs @@ -16,6 +16,9 @@ type SmartDate = (String,String,String) data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord) +data Interval = NoInterval | Daily | Weekly | Monthly | Quarterly | Yearly + deriving (Eq,Show,Ord) + type AccountName = String data Side = L | R deriving (Eq,Show,Ord) diff --git a/NOTES b/NOTES index b934a5a52..3597ed0d6 100644 --- a/NOTES +++ b/NOTES @@ -11,30 +11,7 @@ clever tricks like the plague." --Edsger Dijkstra * to do ** errors ** features -*** period expressions, for ease of use -**** from and/or to -**** reporting intervals -***** design types -***** parse intervals - every day - every week - every monthly - every quarter - every year - every N days # N is any integer - every N weeks - every N months - every N quarters - every N years - daily - weekly - biweekly - monthly - bimonthly - quarterly - yearly -***** implement in register report -***** -W/-M/-Y +*** show empty reporting intervals with the -E option, for clarity/consistency/graphing *** actual/effective entry & txn dates, for completeness *** speed **** easy profiling @@ -43,6 +20,15 @@ clever tricks like the plague." --Edsger Dijkstra *** ~/.hledgerrc, for setting defaults *** more ledger features from README (?) *** new features +**** support complete period syntax ? + every N days # N is any integer + every N weeks + every N months + every N quarters + every N years + biweekly + bimonthly +**** -Q quarterly interval option, for consistency/convenience ? **** easy timelog queries when called as hours **** curses gui **** web gui diff --git a/Options.hs b/Options.hs index dea2bf7b5..6c73e5849 100644 --- a/Options.hs +++ b/Options.hs @@ -50,6 +50,9 @@ options = [ Option [] ["options-anywhere"] (NoArg OptionsAnywhere) "allow options anywhere, use ^ to negate patterns", Option ['n'] ["collapse"] (NoArg Collapse) "balance report: no grand total", Option ['s'] ["subtotal"] (NoArg SubTotal) "balance report: show subaccounts", + Option ['W'] ["weekly"] (NoArg WeeklyOpt) "register report: show weekly summary", + Option ['M'] ["monthly"] (NoArg MonthlyOpt) "register report: show monthly summary", + Option ['Y'] ["yearly"] (NoArg YearlyOpt) "register report: show yearly summary", Option ['h'] ["help"] (NoArg Help) "show this help", Option ['v'] ["verbose"] (NoArg Verbose) "verbose test output", Option ['V'] ["version"] (NoArg Version) "show version" @@ -73,15 +76,24 @@ data Opt = OptionsAnywhere | Collapse | SubTotal | + WeeklyOpt | + MonthlyOpt | + YearlyOpt | Help | Verbose | Version deriving (Show,Eq) -- yow.. +optsWithConstructor f opts = concatMap get opts + where get o = if f v == o then [o] else [] where v = value o + optValuesForConstructor f opts = concatMap get opts where get o = if f v == o then [v] else [] where v = value o +optValuesForConstructors fs opts = concatMap get opts + where get o = if any (\f -> f v == o) fs then [v] else [] where v = value o + -- | Parse the command-line arguments into ledger options, ledger command -- name, and ledger command arguments. Also any dates in the options are -- converted to full YYYY/MM/DD format, while we are in the IO monad @@ -109,22 +121,37 @@ fixOptDates opts = do where fixbracketeddatestr s = "[" ++ (fixSmartDateStr t $ init $ tail s) ++ "]" fixopt _ o = o --- | Figure out the date span we should report on, based on any --- begin/end/period options provided. This could be really smart but I'm --- just going to look for 1. the first Period or 2. the first Begin and --- first End. +-- | Figure out the overall date span we should report on, based on any +-- begin/end/period options provided. If there is a period option, the +-- others are ignored. dateSpanFromOpts :: Day -> [Opt] -> DateSpan -dateSpanFromOpts refdate opts - | not $ null ps = spanFromPeriodExpr refdate $ head ps +dateSpanFromOpts refdate opts + | not $ null popts = snd $ parsePeriodExpr refdate $ head popts | otherwise = DateSpan firstb firste where - ps = optValuesForConstructor Period opts - firstb = listtomaybeday $ optValuesForConstructor Begin opts - firste = listtomaybeday $ optValuesForConstructor End opts - listtomaybeday [] = Nothing - listtomaybeday vs = Just $ parse $ head vs - parse s = parsedate $ printf "%04s/%02s/%02s" y m d - where (y,m,d) = fromparse $ parsewith smartdate $ s + popts = optValuesForConstructor Period opts + bopts = optValuesForConstructor Begin opts + eopts = optValuesForConstructor End opts + firstb = listtomaybeday bopts + firste = listtomaybeday eopts + listtomaybeday vs = if null vs then Nothing else Just $ parse $ head vs + where parse = parsedate . fixSmartDateStr refdate + +-- | Figure out the reporting interval, if any, specified by the options. +-- If there is a period option, the others are ignored. +intervalFromOpts :: [Opt] -> Interval +intervalFromOpts opts + | not $ null popts = fst $ parsePeriodExpr refdate $ head popts + | otherwise = case otheropts of + [] -> NoInterval + (WeeklyOpt:_) -> Weekly + (MonthlyOpt:_) -> Monthly + (YearlyOpt:_) -> Yearly + where + popts = optValuesForConstructor Period opts + otheropts = filter (`elem` [WeeklyOpt,MonthlyOpt,YearlyOpt]) opts + -- doesn't affect the interval, but parsePeriodExpr needs something + refdate = parsedate "0001/01/01" -- | Get the value of the (first) depth option, if any. depthFromOpts :: [Opt] -> Maybe Int diff --git a/README b/README index 46cbb505a..ba2e208be 100644 --- a/README +++ b/README @@ -158,8 +158,12 @@ Other differences * hledger keeps differently-priced amounts of the same commodity separate, at the moment * hledger refers to the entry and transaction "description", ledger calls it "note" * hledger doesn't require a space after flags like -f -* hledger always shows timelog balances in hours * hledger doesn't parse all ledger file constructs (and may choke ? please report) -* hledger doesn't count an unfinished timelog session * hledger interprets "last/this/next week" as weeks beginning on monday * hledger provides "--cost" as a synonym for "--basis" +* hledger's "weekly" reporting intervals always start on mondays +* hledger shows start and end dates of full intervals, not just the span containing data +* hledger period expressions don't support "biweekly", "bimonthly", or "every N days/weeks/..." +* hledger always shows timelog balances in hours +* hledger doesn't count an unfinished timelog session +* (disabled for now: hledger counts timelog sessions on the day they end, ledger on the day they start) diff --git a/RegisterCommand.hs b/RegisterCommand.hs index 188177f61..3c91c3740 100644 --- a/RegisterCommand.hs +++ b/RegisterCommand.hs @@ -6,6 +6,8 @@ A ledger-compatible @register@ command. module RegisterCommand where +import qualified Data.Map as Map +import Data.Map ((!)) import Ledger import Options @@ -26,32 +28,85 @@ DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA @ -} showRegisterReport :: [Opt] -> [String] -> Ledger -> String -showRegisterReport opts args l = showtxns ts nulltxn nullmixedamt +showRegisterReport opts args l + | interval == NoInterval = showtxns ts nulltxn nullmixedamt + | otherwise = showtxns summaryts nulltxn nullmixedamt where - ts = filter matchapats $ ledgerTransactions l + interval = intervalFromOpts opts + ts = filter (not . isZeroMixedAmount . amount) $ filter (matchdisplayopt dopt) $ filter matchapats $ ledgerTransactions l matchapats t = matchpats apats $ account t apats = fst $ parseAccountDescriptionArgs opts args matchdisplayopt Nothing t = True matchdisplayopt (Just e) t = (fromparse $ parsewith datedisplayexpr e) t dopt = displayFromOpts opts - - -- show display-filtered transactions, one per line, with a running balance - showtxns [] _ _ = "" - showtxns (t@Transaction{amount=a}:ts) tprev bal = - (if (isZeroMixedAmount a || (not $ matchdisplayopt dopt t)) then "" else this) ++ showtxns ts t bal' + empty = Empty `elem` opts + summaryts = concat $ map (\(n,s) -> summarise n s (filter (isTransactionInDateSpan s) ts)) $ zip [1..] spans + spans = splitSpan interval (ledgerDateSpan l) + -- generate a grouped set of summary transactions for this date span + summarise :: Int -> DateSpan -> [Transaction] -> [Transaction] + summarise _ _ [] = [] + summarise n (DateSpan b e) ts = summarytxns (b',e') n empty ts where - this = showtxn (t `issame` tprev) t bal' - issame t1 t2 = entryno t1 == entryno t2 - bal' = bal + amount t + b' = fromMaybe (date $ head ts) b + e' = fromMaybe (date $ last ts) e - -- show one transaction line, with or without the entry details - showtxn :: Bool -> Transaction -> MixedAmount -> String - showtxn omitdesc t b = concatBottomPadded [entrydesc ++ txn ++ " ", bal] ++ "\n" - where - entrydesc = if omitdesc then replicate 32 ' ' else printf "%s %s " date desc - date = showDate $ da - desc = printf "%-20s" $ elideRight 20 de :: String - txn = showRawTransaction $ RawTransaction a amt "" tt - bal = padleft 12 (showMixedAmountOrZero b) - Transaction{date=da,description=de,account=a,amount=amt,ttype=tt} = t +-- | Does the given transaction fall within the given date span ? +isTransactionInDateSpan :: DateSpan -> Transaction -> Bool +isTransactionInDateSpan (DateSpan Nothing Nothing) _ = True +isTransactionInDateSpan (DateSpan Nothing (Just e)) (Transaction{date=d}) = d=b +isTransactionInDateSpan (DateSpan (Just b) (Just e)) (Transaction{date=d}) = d>=b && d Int -> Bool -> [Transaction] -> [Transaction] +summarytxns (b,e) entryno showempty ts = summaryts' + where + summaryts' + | showempty = summaryts + | otherwise = filter (not . isZeroMixedAmount . amount) summaryts + summaryts = [templtxn{account=a,amount=balmap ! a} | a <- anames] + templtxn = nulltxn{entryno=entryno,date=b,description="- "++(showDate eprev)} + eprev = addDays (-1) e + anames = sort $ nub $ map account ts + -- from cacheLedger: + sortedts = sortBy (comparing account) ts + groupedts = groupBy (\t1 t2 -> account t1 == account t2) sortedts + txnmap = Map.union + (Map.fromList [(account $ head g, g) | g <- groupedts]) + (Map.fromList [(a,[]) | a <- anames]) + txnsof = (txnmap !) + subacctsof a = filter (a `isAccountNamePrefixOf`) anames + subtxnsof a = concat [txnsof a | a <- [a] ++ subacctsof a] + balmap = Map.union + (Map.fromList [(a,(sumTransactions $ subtxnsof a)) | a <- anames]) + (Map.fromList [(a,Mixed []) | a <- anames]) + -- + +-- | Show transactions one per line, with each date/description appearing +-- only once, and a running balance. +showtxns [] _ _ = "" +showtxns (t@Transaction{amount=a}:ts) tprev bal = this ++ showtxns ts t bal' + where + this = showtxn (t `issame` tprev) t bal' + issame t1 t2 = entryno t1 == entryno t2 + bal' = bal + amount t + +-- | Show one transaction line and balance with or without the entry details. +showtxn :: Bool -> Transaction -> MixedAmount -> String +showtxn omitdesc t b = concatBottomPadded [entrydesc ++ txn ++ " ", bal] ++ "\n" + where + entrydesc = if omitdesc then replicate 32 ' ' else printf "%s %s " date desc + date = showDate $ da + desc = printf "%-20s" $ elideRight 20 de :: String + txn = showRawTransaction $ RawTransaction a amt "" tt + bal = padleft 12 (showMixedAmountOrZero b) + Transaction{date=da,description=de,account=a,amount=amt,ttype=tt} = t diff --git a/Tests.hs b/Tests.hs index c64f79aab..110f3c533 100644 --- a/Tests.hs +++ b/Tests.hs @@ -129,6 +129,33 @@ misc_tests = TestList [ "this year" `gives` "2008/01/01" "last year" `gives` "2007/01/01" "next year" `gives` "2009/01/01" + , + "dateSpanFromOpts" ~: do + let todaysdate = parsedate "2008/11/26" + let opts `gives` spans = assertequal spans (show $ dateSpanFromOpts todaysdate opts) + [] `gives` "DateSpan Nothing Nothing" + [Begin "2008", End "2009"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)" + [Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)" + [Begin "2005", End "2007",Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)" + , + "intervalFromOpts" ~: do + let opts `gives` interval = assertequal interval (intervalFromOpts opts) + [] `gives` NoInterval + [WeeklyOpt] `gives` Weekly + [MonthlyOpt] `gives` Monthly + [YearlyOpt] `gives` Yearly + [Period "weekly"] `gives` Weekly + [Period "monthly"] `gives` Monthly + [WeeklyOpt, Period "yearly"] `gives` Yearly + , + "period expressions" ~: do + let todaysdate = parsedate "2008/11/26" + let str `gives` result = assertequal ("Right "++result) (show $ parsewith (periodexpr todaysdate) str) + "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 day from aug to oct" `gives` "(Daily,DateSpan (Just 2008-08-01) (Just 2008-10-01))" + "daily from aug" `gives` "(Daily,DateSpan (Just 2008-08-01) Nothing)" + "every week to 2009" `gives` "(Weekly,DateSpan Nothing (Just 2009-01-01))" ] balancereportacctnames_tests = TestList @@ -354,10 +381,26 @@ registercommand_tests = TestList [ , "register report with period expression" ~: do - "" `periodexprgives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] + "" `periodexprgives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] "2008" `periodexprgives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] --- need to get datespan into ledgerFromString, or preconvert period expressions --- "2007" `periodexprgives` [] + "2007" `periodexprgives` [] + "june" `periodexprgives` ["2008/06/01","2008/06/02","2008/06/03"] + + let l = ledgerfromstring [] sample_ledger_str + assertequal ( + "2008/01/01 - 2008/12/31 assets:cash $-2 $-2\n" ++ + " assets:saving $1 $-1\n" ++ + " expenses:food $1 0\n" ++ + " expenses:supplies $1 $1\n" ++ + " income:gifts $-1 0\n" ++ + " income:salary $-1 $-1\n" ++ + " liabilities:debts $1 0\n" ++ + "") + (showRegisterReport [Period "yearly"] [] l) + + assertequal ["2008/01/01","2008/04/01","2008/10/01"] (datesfromregister $ showRegisterReport [Period "quarterly"] [] l) +-- assertequal ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"] (datesfromregister $ showRegisterReport [Period "quarterly"] [] l) + ] where expr `displayexprgives` dates = @@ -369,9 +412,9 @@ registercommand_tests = TestList [ assertequal dates (datesfromregister r) where r = showRegisterReport [Period expr] [] l - l = ledgerfromstring [] sample_ledger_str - -datesfromregister = filter (not . null) . map (strip . take 10) . lines + l = ledgerfromstringwithopts [Period expr] [] refdate sample_ledger_str + refdate = parsedate "2008/11/26" + datesfromregister = filter (not . null) . map (strip . take 10) . lines ------------------------------------------------------------------------------