]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Date/Interval.hs
Polissage : Lib.Parsec : espaces.
[comptalang.git] / 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