From 94537f30d4ade0152c468d0c6ba6d15af9a2ead8 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Fri, 29 Jul 2016 10:27:30 -0700 Subject: [PATCH] lib: Period, a richer period type --- hledger-lib/Hledger/Data.hs | 2 + hledger-lib/Hledger/Data/Period.hs | 118 +++++++++++++++++++++++++++++ hledger-lib/Hledger/Data/Types.hs | 58 ++++++++++++-- 3 files changed, 171 insertions(+), 7 deletions(-) create mode 100644 hledger-lib/Hledger/Data/Period.hs diff --git a/hledger-lib/Hledger/Data.hs b/hledger-lib/Hledger/Data.hs index 96a72261a..f55b28a96 100644 --- a/hledger-lib/Hledger/Data.hs +++ b/hledger-lib/Hledger/Data.hs @@ -15,6 +15,7 @@ module Hledger.Data ( module Hledger.Data.Dates, module Hledger.Data.Journal, module Hledger.Data.Ledger, + module Hledger.Data.Period, module Hledger.Data.Posting, module Hledger.Data.RawOptions, module Hledger.Data.StringFormat, @@ -33,6 +34,7 @@ import Hledger.Data.Commodity import Hledger.Data.Dates import Hledger.Data.Journal import Hledger.Data.Ledger +import Hledger.Data.Period import Hledger.Data.Posting import Hledger.Data.RawOptions import Hledger.Data.StringFormat diff --git a/hledger-lib/Hledger/Data/Period.hs b/hledger-lib/Hledger/Data/Period.hs new file mode 100644 index 000000000..f8aaa9965 --- /dev/null +++ b/hledger-lib/Hledger/Data/Period.hs @@ -0,0 +1,118 @@ +{-| + +Manipulating the time periods typically used for reports +using Period, a richer abstraction than DateSpan. +See also Types and Dates. + +-} + +module Hledger.Data.Period +where + +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate + +import Hledger.Data.Types +import Hledger.Data.Dates () -- DateSpan Show instance + +-- | Convert Periods to DateSpans. +-- +-- >>> periodAsDateSpan (MonthPeriod 2000 1) == DateSpan (Just $ fromGregorian 2000 1 1) (Just $ fromGregorian 2000 2 1) +-- True +periodAsDateSpan :: Period -> DateSpan +periodAsDateSpan (DayPeriod d) = DateSpan (Just d) (Just $ addDays 1 d) +periodAsDateSpan (WeekPeriod b) = DateSpan (Just b) (Just $ addDays 7 b) +periodAsDateSpan (MonthPeriod y m) = DateSpan (Just $ fromGregorian y m 1) (Just $ fromGregorian y' m' 1) + where + (y',m') | m==12 = (y+1,1) + | otherwise = (y,m+1) +periodAsDateSpan (QuarterPeriod y q) = DateSpan (Just $ fromGregorian y m 1) (Just $ fromGregorian y' m' 1) + where + (y', q') | q==4 = (y+1,1) + | otherwise = (y,q+1) + quarterAsMonth q = (q-1) * 3 + 1 + m = quarterAsMonth q + m' = quarterAsMonth q' +periodAsDateSpan (YearPeriod y) = DateSpan (Just $ fromGregorian y 1 1) (Just $ fromGregorian (y+1) 1 1) +periodAsDateSpan (PeriodBetween b e) = DateSpan (Just b) (Just e) +periodAsDateSpan (PeriodFrom b) = DateSpan (Just b) Nothing +periodAsDateSpan (PeriodTo e) = DateSpan Nothing (Just e) +periodAsDateSpan (PeriodAll) = DateSpan Nothing Nothing + +-- | Convert DateSpans to Periods. +-- +-- >>> dateSpanAsPeriod $ DateSpan (Just $ fromGregorian 2000 1 1) (Just $ fromGregorian 2000 2 1) +-- MonthPeriod 2000 1 +dateSpanAsPeriod :: DateSpan -> Period +dateSpanAsPeriod (DateSpan (Just b) (Just e)) = simplifyPeriod $ PeriodBetween b e +dateSpanAsPeriod (DateSpan (Just b) Nothing) = PeriodFrom b +dateSpanAsPeriod (DateSpan Nothing (Just e)) = PeriodTo e +dateSpanAsPeriod (DateSpan Nothing Nothing) = PeriodAll + +-- | Convert PeriodBetweens to a more abstract period where possible. +-- +-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 1 1 1) (fromGregorian 2 1 1) +-- YearPeriod 1 +-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 10 1) (fromGregorian 2001 1 1) +-- QuarterPeriod 2000 4 +-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 2 1) (fromGregorian 2000 3 1) +-- MonthPeriod 2000 2 +-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2016 7 25) (fromGregorian 2016 8 1) +-- WeekPeriod 2016-07-25 +-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 1 1) (fromGregorian 2000 1 2) +-- DayPeriod 2000-01-01 +-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 2 28) (fromGregorian 2000 3 1) +-- PeriodBetween 2000-02-28 2000-03-01 +-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 2 29) (fromGregorian 2000 3 1) +-- DayPeriod 2000-02-29 +-- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 12 31) (fromGregorian 2001 1 1) +-- DayPeriod 2000-12-31 +-- +simplifyPeriod :: Period -> Period +simplifyPeriod (PeriodBetween b e) = + case (toGregorian b, toGregorian e) of + -- a year + ((by,1,1), (ey,1,1)) | by+1==ey -> YearPeriod by + -- a half-year + -- ((by,1,1), (ey,7,1)) | by==ey -> + -- ((by,7,1), (ey,1,1)) | by+1==ey -> + -- a quarter + ((by,1,1), (ey,4,1)) | by==ey -> QuarterPeriod by 1 + ((by,4,1), (ey,7,1)) | by==ey -> QuarterPeriod by 2 + ((by,7,1), (ey,10,1)) | by==ey -> QuarterPeriod by 3 + ((by,10,1), (ey,1,1)) | by+1==ey -> QuarterPeriod by 4 + -- a month + ((by,bm,1), (ey,em,1)) | by==ey && bm+1==em -> MonthPeriod by bm + ((by,12,1), (ey,1,1)) | by+1==ey -> MonthPeriod by 12 + -- a week (two successive mondays), + -- YYYYwN ("week N of year YYYY") + -- _ | let ((by,bw,bd), (ey,ew,ed)) = (toWeekDate from, toWeekDate to) in by==ey && fw+1==tw && bd==1 && ed==1 -> + -- a week starting on a monday + _ | let ((by,bw,bd), (ey,ew,ed)) = (toWeekDate b, toWeekDate (addDays (-1) e)) + in by==ey && bw==ew && bd==1 && ed==7 -> WeekPeriod b + -- a day + ((by,bm,bd), (ey,em,ed)) | + (by==ey && bm==em && bd+1==ed) || + (by+1==ey && bm==12 && em==1 && bd==31 && ed==1) || -- crossing a year boundary + (by==ey && bm+1==em && isLastDayOfMonth by bm bd && ed==1) -- crossing a month boundary + -> DayPeriod b + _ -> PeriodBetween b e +simplifyPeriod p = p + +isLastDayOfMonth y m d = + case m of + 1 -> d==31 + 2 | isLeapYear y -> d==29 + | otherwise -> d==28 + 3 -> d==31 + 4 -> d==30 + 5 -> d==31 + 6 -> d==30 + 7 -> d==31 + 8 -> d==31 + 9 -> d==30 + 10 -> d==31 + 11 -> d==30 + 12 -> d==31 + _ -> False + diff --git a/hledger-lib/Hledger/Data/Types.hs b/hledger-lib/Hledger/Data/Types.hs index c504cbe55..773d0d054 100644 --- a/hledger-lib/Hledger/Data/Types.hs +++ b/hledger-lib/Hledger/Data/Types.hs @@ -45,11 +45,57 @@ data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Ord,Data,Generic,T instance NFData DateSpan -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,Data,Generic,Typeable) +-- synonyms for various date-related scalars +type Year = Integer +type Month = Int -- 1-12 +type Quarter = Int -- 1-4 +type YearWeek = Int -- 1-52 +type MonthWeek = Int -- 1-5 +type YearDay = Int -- 1-366 +type MonthDay = Int -- 1-31 +type WeekDay = Int -- 1-7 + +-- Typical report periods (spans of time), both finite and open-ended. +-- A richer abstraction than DateSpan. +data Period = + DayPeriod Day + | WeekPeriod Day + | MonthPeriod Year Month + | QuarterPeriod Year Quarter + | YearPeriod Year + | PeriodBetween Day Day + | PeriodFrom Day + | PeriodTo Day + | PeriodAll + deriving (Eq,Ord,Show,Data,Generic,Typeable) + +instance Default Period where def = PeriodAll + +---- Typical report period/subperiod durations, from a day to a year. +--data Duration = +-- DayLong +-- WeekLong +-- MonthLong +-- QuarterLong +-- YearLong +-- deriving (Eq,Ord,Show,Data,Generic,Typeable) + +-- Ways in which a period can be divided into subperiods. +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,Data,Generic,Typeable) + +instance Default Interval where def = NoInterval instance NFData Interval @@ -223,8 +269,6 @@ data MarketPrice = MarketPrice { instance NFData MarketPrice -type Year = Integer - -- | A Journal, containing transactions and various other things. -- The basic data model for hledger. --