lib/Hcompta/Date/Interval.hs

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