lib/Hcompta/Date/Interval.hs

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