1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 module Hcompta.Date.Interval where
4 -- import qualified Data.Fixed -- NOTE: not useful before base >=4.7
5 import Data.Function (($))
6 import Data.Interval (Interval)
7 import qualified Data.Interval as Interval
8 import qualified Data.List
9 import Data.Maybe (Maybe(..), fromJust)
10 import qualified Data.Time.Calendar as Time
11 import qualified Data.Time.Clock as Time
12 import qualified Data.Time.Format as Time ()
13 import qualified Data.Time.LocalTime as Time
14 import Prelude (Integral(..), Num(..))
16 import Hcompta.Date hiding (year, month, dom, hour, minute, second)
17 import qualified Hcompta.Date as Date
22 year :: Year -> Interval Date
24 let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
25 let hy = Time.addGregorianYearsClip 1 ly in
26 fromJust $ (Interval.<=..<)
30 month :: Year -> Month -> Interval Date
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.<=..<)
39 dom :: Year -> Month -> DoM -> Interval Date
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.<=..<)
49 hour :: Year -> Month -> DoM -> Hour -> Interval Date
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
58 minute :: Year -> Month -> DoM -> Hour -> Minute -> Interval Date
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
68 {- NOTE: Data.Fixed.MkFixed requires base >=4.7
69 second :: Year -> Month -> DoM -> Hour -> Minute -> Second -> Interval Date
70 second y m d h n (Data.Fixed.MkFixed s) =
71 let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
72 let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
73 let ld = nil{Time.utctDay=Time.addDays (toInteger d - 1) lm} in
74 let lh = Time.addUTCTime (fromInteger $ toInteger (h * 3600)) ld in
75 let ln = Time.addUTCTime (fromInteger $ toInteger (n * 60)) lh in
76 let ls = Time.addUTCTime (fromInteger $ s) ln in
77 let hs = Time.addUTCTime 1 ls in
78 fromJust $ (Interval.<=..<) ls hs
83 slice :: (Date -> Interval Date) -> Interval Date -> [Interval Date]
86 (\last_slice -> case Interval.intersection i last_slice of
88 Just n -> Just (n, slicer (Interval.limit $ Interval.high last_slice))
90 slicer (Interval.limit $ Interval.low i)
92 year_slice :: Date -> Interval Date
94 let (y, _, _) = Date.gregorian d in
97 month_slice :: Date -> Interval Date
99 let (y, m, _) = Date.gregorian d in
102 dom_slice :: Date -> Interval Date
104 let (y, m, o) = Date.gregorian d in
107 hour_slice :: Date -> Interval Date
109 let (y, m, o) = Date.gregorian d in
110 let Time.TimeOfDay h _ _ = tod d in
113 minute_slice :: Date -> Interval Date
115 let (y, m, o) = Date.gregorian d in
116 let Time.TimeOfDay h n _ = tod d in
120 second_slice :: Date -> Interval Date
122 let (y, m, o) = Date.gregorian d in
123 let Time.TimeOfDay h n s = tod d in