From e96dfc639e3628a01c71ce77ab395998969b5404 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Fri, 14 Jan 2011 02:35:00 +0000 Subject: [PATCH] support "every N day/week/month/quarter/years" reporting intervals --- hledger-lib/Hledger/Data/Dates.hs | 60 +++++++++++++++++++------------ hledger-lib/Hledger/Data/Types.hs | 3 +- hledger/Hledger/Cli/Histogram.hs | 2 +- hledger/Hledger/Cli/Options.hs | 28 +++++++-------- hledger/Hledger/Cli/Register.hs | 2 +- 5 files changed, 56 insertions(+), 39 deletions(-) diff --git a/hledger-lib/Hledger/Data/Dates.hs b/hledger-lib/Hledger/Data/Dates.hs index bb4184cdf..42b4caebe 100644 --- a/hledger-lib/Hledger/Data/Dates.hs +++ b/hledger-lib/Hledger/Data/Dates.hs @@ -420,19 +420,35 @@ dateperiodexpr rdate = do return (NoInterval, s) periodexprinterval :: GenParser Char st Interval -periodexprinterval = - choice $ map try [ - tryinterval "day" "daily" Daily, - tryinterval "week" "weekly" Weekly, - tryinterval "" "biweekly" Biweekly, - tryinterval "month" "monthly" Monthly, - tryinterval "" "bimonthly" Bimonthly, - tryinterval "quarter" "quarterly" Quarterly, - tryinterval "year" "yearly" Yearly +periodexprinterval = choice' [ + tryinterval "day" "daily" Days, + tryinterval "week" "weekly" Weeks, + tryinterval "month" "monthly" Months, + tryinterval "quarter" "quarterly" Quarters, + tryinterval "year" "yearly" Years, + do string "biweekly" + return $ Weeks 2, + do string "bimonthly" + return $ Months 2 ] where - tryinterval "" s2 v = try (string s2) >> return v - tryinterval s1 s2 v = choice [try (string $ "every "++s1), try (string s2)] >> return v + tryinterval :: String -> String -> (Int -> Interval) -> GenParser Char st Interval + tryinterval singular compact intcons = + choice' [ + do string compact + return $ intcons 1, + do string "every" + many spacenonewline + string singular + return $ intcons 1, + do string "every" + many spacenonewline + n <- fmap read $ many1 digit + many spacenonewline + string plural + return $ intcons n + ] + where plural = singular ++ "s" periodexprdatespan :: Day -> GenParser Char st DateSpan periodexprdatespan rdate = choice $ map try [ @@ -483,33 +499,33 @@ tests_Hledger_Data_Dates = TestList let gives (interval, span) = (splitSpan interval span `is`) (NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives` [mkdatespan "2008/01/01" "2009/01/01"] - (Quarterly,mkdatespan "2008/01/01" "2009/01/01") `gives` + (Quarters 1,mkdatespan "2008/01/01" "2009/01/01") `gives` [mkdatespan "2008/01/01" "2008/04/01" ,mkdatespan "2008/04/01" "2008/07/01" ,mkdatespan "2008/07/01" "2008/10/01" ,mkdatespan "2008/10/01" "2009/01/01" ] - (Quarterly,nulldatespan) `gives` + (Quarters 1,nulldatespan) `gives` [nulldatespan] - (Daily,mkdatespan "2008/01/01" "2008/01/01") `gives` + (Days 1,mkdatespan "2008/01/01" "2008/01/01") `gives` [mkdatespan "2008/01/01" "2008/01/01"] - (Quarterly,mkdatespan "2008/01/01" "2008/01/01") `gives` + (Quarters 1,mkdatespan "2008/01/01" "2008/01/01") `gives` [mkdatespan "2008/01/01" "2008/01/01"] - (Monthly,mkdatespan "2008/01/01" "2008/04/01") `gives` + (Months 1,mkdatespan "2008/01/01" "2008/04/01") `gives` [mkdatespan "2008/01/01" "2008/02/01" ,mkdatespan "2008/02/01" "2008/03/01" ,mkdatespan "2008/03/01" "2008/04/01" ] - (Bimonthly,mkdatespan "2008/01/01" "2008/04/01") `gives` + (Months 2,mkdatespan "2008/01/01" "2008/04/01") `gives` [mkdatespan "2008/01/01" "2008/03/01" ,mkdatespan "2008/03/01" "2008/05/01" ] - (Weekly,mkdatespan "2008/01/01" "2008/01/15") `gives` + (Weeks 1,mkdatespan "2008/01/01" "2008/01/15") `gives` [mkdatespan "2007/12/31" "2008/01/07" ,mkdatespan "2008/01/07" "2008/01/14" ,mkdatespan "2008/01/14" "2008/01/21" ] - (Biweekly,mkdatespan "2008/01/01" "2008/01/15") `gives` + (Weeks 2,mkdatespan "2008/01/01" "2008/01/15") `gives` [mkdatespan "2007/12/31" "2008/01/14" ,mkdatespan "2008/01/14" "2008/01/28" ] @@ -524,9 +540,9 @@ tests_Hledger_Data_Dates = TestList 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 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))" + "every 3 days from aug to oct" `gives` "(Days 3,DateSpan (Just 2008-08-01) (Just 2008-10-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))" ,"fixSmartDateStr" ~: do let gives = is . fixSmartDateStr (parsedate "2008/11/26") diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index d4207853e..86af657be 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -46,7 +46,8 @@ data WhichDate = ActualDate | EffectiveDate deriving (Eq,Show) data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord) -data Interval = NoInterval | Daily | Weekly | Biweekly | Monthly | Bimonthly | Quarterly | Yearly +data Interval = NoInterval + | Days Int | Weeks Int | Months Int | Quarters Int | Years Int deriving (Eq,Show,Ord) type AccountName = String diff --git a/hledger/Hledger/Cli/Histogram.hs b/hledger/Hledger/Cli/Histogram.hs index 2867c92c8..376d10641 100644 --- a/hledger/Hledger/Cli/Histogram.hs +++ b/hledger/Hledger/Cli/Histogram.hs @@ -28,7 +28,7 @@ showHistogram :: [Opt] -> FilterSpec -> Journal -> String showHistogram opts filterspec j = concatMap (printDayWith countBar) dayps where i = intervalFromOpts opts - interval | i == NoInterval = Daily + interval | i == NoInterval = Days 1 | otherwise = i fullspan = journalDateSpan j days = filter (DateSpan Nothing Nothing /=) $ splitSpan interval fullspan diff --git a/hledger/Hledger/Cli/Options.hs b/hledger/Hledger/Cli/Options.hs index 96ee309e7..6bb673570 100644 --- a/hledger/Hledger/Cli/Options.hs +++ b/hledger/Hledger/Cli/Options.hs @@ -198,11 +198,11 @@ intervalFromOpts opts = ((p:_), _) -> case parsePeriodExpr (parsedate "0001/01/01") p of Right (i, _) -> i Left e -> parseerror e - (_, (DailyOpt:_)) -> Daily - (_, (WeeklyOpt:_)) -> Weekly - (_, (MonthlyOpt:_)) -> Monthly - (_, (QuarterlyOpt:_)) -> Quarterly - (_, (YearlyOpt:_)) -> Yearly + (_, (DailyOpt:_)) -> Days 1 + (_, (WeeklyOpt:_)) -> Weeks 1 + (_, (MonthlyOpt:_)) -> Months 1 + (_, (QuarterlyOpt:_)) -> Quarters 1 + (_, (YearlyOpt:_)) -> Years 1 (_, _) -> NoInterval where periodopts = reverse $ optValuesForConstructor Period opts @@ -308,14 +308,14 @@ tests_Hledger_Cli_Options = TestList ,"intervalFromOpts" ~: do let gives = is . intervalFromOpts [] `gives` NoInterval - [DailyOpt] `gives` Daily - [WeeklyOpt] `gives` Weekly - [MonthlyOpt] `gives` Monthly - [QuarterlyOpt] `gives` Quarterly - [YearlyOpt] `gives` Yearly - [Period "weekly"] `gives` Weekly - [Period "monthly"] `gives` Monthly - [Period "quarterly"] `gives` Quarterly - [WeeklyOpt, Period "yearly"] `gives` Yearly + [DailyOpt] `gives` Days 1 + [WeeklyOpt] `gives` Weeks 1 + [MonthlyOpt] `gives` Months 1 + [QuarterlyOpt] `gives` Quarters 1 + [YearlyOpt] `gives` Years 1 + [Period "weekly"] `gives` Weeks 1 + [Period "monthly"] `gives` Months 1 + [Period "quarterly"] `gives` Quarters 1 + [WeeklyOpt, Period "yearly"] `gives` Years 1 ] \ No newline at end of file diff --git a/hledger/Hledger/Cli/Register.hs b/hledger/Hledger/Cli/Register.hs index c3f232b78..3338f7265 100644 --- a/hledger/Hledger/Cli/Register.hs +++ b/hledger/Hledger/Cli/Register.hs @@ -203,7 +203,7 @@ tests_Hledger_Cli_Register = TestList [ "summarisePostingsByInterval" ~: do - summarisePostingsByInterval Quarterly Nothing False (DateSpan Nothing Nothing) [] ~?= [] + summarisePostingsByInterval (Quarters 1) Nothing False (DateSpan Nothing Nothing) [] ~?= [] -- ,"summarisePostingsInDateSpan" ~: do -- let gives (b,e,depth,showempty,ps) =