lib: Period, a richer period type

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

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
+

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
+-- synonyms for various date-related scalars
-              | Days Int | Weeks Int | Months Int | Quarters Int | Years Int
+type Year = Integer
-              | DayOfMonth Int | DayOfWeek Int
+type Month = Int     -- 1-12
-              -- WeekOfYear Int | MonthOfYear Int | QuarterOfYear Int
+type Quarter = Int   -- 1-4
-                deriving (Eq,Show,Ord,Data,Generic,Typeable)
+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.
 --