slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

support "every N day/week/month/quarter/years" reporting intervals

Browse Source
This commit is contained in:
Simon Michael 2011-01-14 02:35:00 +00:00
parent 6de45f7d16
commit e96dfc639e
5 changed files with 56 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
hledger-lib/Hledger/Data/Dates.hs
View File

@ -420,19 +420,35 @@ dateperiodexpr rdate = do
return (NoInterval, s) return (NoInterval, s)
periodexprinterval :: GenParser Char st Interval periodexprinterval :: GenParser Char st Interval
periodexprinterval = periodexprinterval = choice' [
choice $ map try [ tryinterval "day" "daily" Days,
tryinterval "day" "daily" Daily, tryinterval "week" "weekly" Weeks,
tryinterval "week" "weekly" Weekly, tryinterval "month" "monthly" Months,
tryinterval "" "biweekly" Biweekly, tryinterval "quarter" "quarterly" Quarters,
tryinterval "month" "monthly" Monthly, tryinterval "year" "yearly" Years,
tryinterval "" "bimonthly" Bimonthly, do string "biweekly"
tryinterval "quarter" "quarterly" Quarterly, return $ Weeks 2,
tryinterval "year" "yearly" Yearly do string "bimonthly"
return $ Months 2
] ]
where where
tryinterval "" s2 v = try (string s2) >> return v tryinterval :: String -> String -> (Int -> Interval) -> GenParser Char st Interval
tryinterval s1 s2 v = choice [try (string $ "every "++s1), try (string s2)] >> return v 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 :: Day -> GenParser Char st DateSpan
periodexprdatespan rdate = choice $ map try [ periodexprdatespan rdate = choice $ map try [
@ -483,33 +499,33 @@ tests_Hledger_Data_Dates = TestList
let gives (interval, span) = (splitSpan interval span `is`) let gives (interval, span) = (splitSpan interval span `is`)
(NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives` (NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives`
[mkdatespan "2008/01/01" "2009/01/01"] [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/01/01" "2008/04/01"
,mkdatespan "2008/04/01" "2008/07/01" ,mkdatespan "2008/04/01" "2008/07/01"
,mkdatespan "2008/07/01" "2008/10/01" ,mkdatespan "2008/07/01" "2008/10/01"
,mkdatespan "2008/10/01" "2009/01/01" ,mkdatespan "2008/10/01" "2009/01/01"
] ]
(Quarterly,nulldatespan) `gives` (Quarters 1,nulldatespan) `gives`
[nulldatespan] [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"] [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"] [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/01/01" "2008/02/01"
,mkdatespan "2008/02/01" "2008/03/01" ,mkdatespan "2008/02/01" "2008/03/01"
,mkdatespan "2008/03/01" "2008/04/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/01/01" "2008/03/01"
,mkdatespan "2008/03/01" "2008/05/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 "2007/12/31" "2008/01/07"
,mkdatespan "2008/01/07" "2008/01/14" ,mkdatespan "2008/01/07" "2008/01/14"
,mkdatespan "2008/01/14" "2008/01/21" ,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 "2007/12/31" "2008/01/14"
,mkdatespan "2008/01/14" "2008/01/28" ,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) 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))" "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))" "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))" "every 3 days from aug to oct" `gives` "(Days 3,DateSpan (Just 2008-08-01) (Just 2008-10-01))"
"daily from aug" `gives` "(Daily,DateSpan (Just 2008-08-01) Nothing)" "daily from aug" `gives` "(Days 1,DateSpan (Just 2008-08-01) Nothing)"
"every week to 2009" `gives` "(Weekly,DateSpan Nothing (Just 2009-01-01))" "every week to 2009" `gives` "(Weeks 1,DateSpan Nothing (Just 2009-01-01))"
,"fixSmartDateStr" ~: do ,"fixSmartDateStr" ~: do
let gives = is . fixSmartDateStr (parsedate "2008/11/26") let gives = is . fixSmartDateStr (parsedate "2008/11/26")

3
hledger-lib/Hledger/Data/Types.hs
View File

@ -46,7 +46,8 @@ data WhichDate = ActualDate | EffectiveDate 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 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) deriving (Eq,Show,Ord)
type AccountName = String type AccountName = String

2
hledger/Hledger/Cli/Histogram.hs
View File

@ -28,7 +28,7 @@ showHistogram :: [Opt] -> FilterSpec -> Journal -> String
showHistogram opts filterspec j = concatMap (printDayWith countBar) dayps showHistogram opts filterspec j = concatMap (printDayWith countBar) dayps
where where
i = intervalFromOpts opts i = intervalFromOpts opts
interval | i == NoInterval = Daily interval | i == NoInterval = Days 1
| otherwise = i | otherwise = i
fullspan = journalDateSpan j fullspan = journalDateSpan j
days = filter (DateSpan Nothing Nothing /=) $ splitSpan interval fullspan days = filter (DateSpan Nothing Nothing /=) $ splitSpan interval fullspan

28
hledger/Hledger/Cli/Options.hs
View File

@ -198,11 +198,11 @@ intervalFromOpts opts =
((p:_), _) -> case parsePeriodExpr (parsedate "0001/01/01") p of ((p:_), _) -> case parsePeriodExpr (parsedate "0001/01/01") p of
Right (i, _) -> i Right (i, _) -> i
Left e -> parseerror e Left e -> parseerror e
(_, (DailyOpt:_)) -> Daily (_, (DailyOpt:_)) -> Days 1
(_, (WeeklyOpt:_)) -> Weekly (_, (WeeklyOpt:_)) -> Weeks 1
(_, (MonthlyOpt:_)) -> Monthly (_, (MonthlyOpt:_)) -> Months 1
(_, (QuarterlyOpt:_)) -> Quarterly (_, (QuarterlyOpt:_)) -> Quarters 1
(_, (YearlyOpt:_)) -> Yearly (_, (YearlyOpt:_)) -> Years 1
(_, _) -> NoInterval (_, _) -> NoInterval
where where
periodopts = reverse $ optValuesForConstructor Period opts periodopts = reverse $ optValuesForConstructor Period opts
@ -308,14 +308,14 @@ tests_Hledger_Cli_Options = TestList
,"intervalFromOpts" ~: do ,"intervalFromOpts" ~: do
let gives = is . intervalFromOpts let gives = is . intervalFromOpts
[] `gives` NoInterval [] `gives` NoInterval
[DailyOpt] `gives` Daily [DailyOpt] `gives` Days 1
[WeeklyOpt] `gives` Weekly [WeeklyOpt] `gives` Weeks 1
[MonthlyOpt] `gives` Monthly [MonthlyOpt] `gives` Months 1
[QuarterlyOpt] `gives` Quarterly [QuarterlyOpt] `gives` Quarters 1
[YearlyOpt] `gives` Yearly [YearlyOpt] `gives` Years 1
[Period "weekly"] `gives` Weekly [Period "weekly"] `gives` Weeks 1
[Period "monthly"] `gives` Monthly [Period "monthly"] `gives` Months 1
[Period "quarterly"] `gives` Quarterly [Period "quarterly"] `gives` Quarters 1
[WeeklyOpt, Period "yearly"] `gives` Yearly [WeeklyOpt, Period "yearly"] `gives` Years 1
] ]

2
hledger/Hledger/Cli/Register.hs
View File

@ -203,7 +203,7 @@ tests_Hledger_Cli_Register = TestList
[ [
"summarisePostingsByInterval" ~: do "summarisePostingsByInterval" ~: do
summarisePostingsByInterval Quarterly Nothing False (DateSpan Nothing Nothing) [] ~?= [] summarisePostingsByInterval (Quarters 1) Nothing False (DateSpan Nothing Nothing) [] ~?= []
-- ,"summarisePostingsInDateSpan" ~: do -- ,"summarisePostingsInDateSpan" ~: do
-- let gives (b,e,depth,showempty,ps) = -- let gives (b,e,depth,showempty,ps) =