lib/Hcompta/Date/Interval.hs

   1 {-# LANGUAGE TypeSynonymInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 module Hcompta.Date.Interval where
   4
   5 import qualified Data.Fixed
   6 import qualified Data.List
   7 import           Data.Maybe (fromJust)
   8 import qualified Data.Time.Calendar    as Time
   9 import qualified Data.Time.Clock       as Time
  10 import qualified Data.Time.Format      as Time ()
  11 import qualified Data.Time.LocalTime   as Time
  12
  13 import           Hcompta.Date hiding (year, month, dom, hour, minute, second)
  14 import qualified Hcompta.Date as Date
  15 import           Hcompta.Lib.Interval (Interval)
  16 import qualified Hcompta.Lib.Interval as Interval
  17
  18
  19 -- *  Gregorian
  20
  21 year :: Year -> Interval Date
  22 year y =
  23         let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
  24         let hy = Time.addGregorianYearsClip 1 ly in
  25         fromJust $ (Interval.<=..<)
  26          nil{Time.utctDay=ly}
  27          nil{Time.utctDay=hy}
  28
  29 month :: Year -> Month -> Interval Date
  30 month y m =
  31         let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
  32         let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
  33         let hm = Time.addGregorianMonthsClip 1 lm in
  34         fromJust $ (Interval.<=..<)
  35          nil{Time.utctDay=lm}
  36          nil{Time.utctDay=hm}
  37
  38 dom :: Year -> Month -> DoM -> Interval Date
  39 dom y m d =
  40         let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
  41         let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
  42         let ld = Time.addDays (toInteger d - 1) lm in
  43         let hd = Time.addDays 1 ld in
  44         fromJust $ (Interval.<=..<)
  45          nil{Time.utctDay=ld}
  46          nil{Time.utctDay=hd}
  47
  48 hour :: Year -> Month -> DoM -> Hour -> Interval Date
  49 hour y m d h =
  50         let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
  51         let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
  52         let ld = nil{Time.utctDay=Time.addDays (toInteger d - 1) lm} in
  53         let lh = Time.addUTCTime (fromInteger $ toInteger (h * 3600)) ld in
  54         let hh = Time.addUTCTime 3600 lh in
  55         fromJust $ (Interval.<=..<) lh hh
  56
  57 minute :: Year -> Month -> DoM -> Hour -> Minute -> Interval Date
  58 minute y m d h n =
  59         let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
  60         let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
  61         let ld = nil{Time.utctDay=Time.addDays (toInteger d - 1) lm} in
  62         let lh = Time.addUTCTime (fromInteger $ toInteger (h * 3600)) ld in
  63         let ln = Time.addUTCTime (fromInteger $ toInteger (n * 60)) lh in
  64         let hn = Time.addUTCTime 60 ln in
  65         fromJust $ (Interval.<=..<) ln hn
  66
  67 second :: Year -> Month -> DoM -> Hour -> Minute -> Second -> Interval Date
  68 second y m d h n (Data.Fixed.MkFixed s) =
  69         let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
  70         let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
  71         let ld = nil{Time.utctDay=Time.addDays (toInteger d - 1) lm} in
  72         let lh = Time.addUTCTime (fromInteger $ toInteger (h * 3600)) ld in
  73         let ln = Time.addUTCTime (fromInteger $ toInteger (n * 60)) lh in
  74         let ls = Time.addUTCTime (fromInteger $ s) ln in
  75         let hs = Time.addUTCTime 1 ls in
  76         fromJust $ (Interval.<=..<) ls hs
  77
  78 -- * Slice
  79
  80 slice :: (Date -> Interval Date) -> Interval Date -> [Interval Date]
  81 slice slicer i =
  82         Data.List.unfoldr
  83          (\last_slice -> case Interval.intersection i last_slice of
  84                  Nothing -> Nothing
  85                  Just n  -> Just (n, slicer (Interval.limit $ Interval.high last_slice))
  86                 ) $
  87         slicer (Interval.limit $ Interval.low i)
  88
  89 year_slice :: Date -> Interval Date
  90 year_slice d =
  91         let (y, _, _) = Date.gregorian d in
  92         year y
  93
  94 month_slice :: Date -> Interval Date
  95 month_slice d =
  96         let (y, m, _) = Date.gregorian d in
  97         month y m
  98
  99 dom_slice :: Date -> Interval Date
 100 dom_slice d =
 101         let (y, m, o) = Date.gregorian d in
 102         dom y m o
 103
 104 hour_slice :: Date -> Interval Date
 105 hour_slice d =
 106         let (y, m, o) = Date.gregorian d in
 107         let Time.TimeOfDay h _ _ = tod d in
 108         hour y m o h
 109
 110 minute_slice :: Date -> Interval Date
 111 minute_slice d =
 112         let (y, m, o) = Date.gregorian d in
 113         let Time.TimeOfDay h n _ = tod d in
 114         minute y m o h n
 115
 116 second_slice :: Date -> Interval Date
 117 second_slice d =
 118         let (y, m, o) = Date.gregorian d in
 119         let Time.TimeOfDay h n s = tod d in
 120         second y m o h n s