]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Date/Interval.hs
Adapte hcompta-cli.
[comptalang.git] / lib / Hcompta / Date / Interval.hs
1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 module Hcompta.Date.Interval where
3
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(..))
15
16 import Hcompta.Date hiding (year, month, dom, hour, minute, second)
17 import qualified Hcompta.Date as Date
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 {- 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
79 -}
80
81 -- * Slice
82
83 slice :: (Date -> Interval Date) -> Interval Date -> [Interval Date]
84 slice slicer i =
85 Data.List.unfoldr
86 (\last_slice -> case Interval.intersection i last_slice of
87 Nothing -> Nothing
88 Just n -> Just (n, slicer (Interval.limit $ Interval.high last_slice))
89 ) $
90 slicer (Interval.limit $ Interval.low i)
91
92 year_slice :: Date -> Interval Date
93 year_slice d =
94 let (y, _, _) = Date.gregorian d in
95 year y
96
97 month_slice :: Date -> Interval Date
98 month_slice d =
99 let (y, m, _) = Date.gregorian d in
100 month y m
101
102 dom_slice :: Date -> Interval Date
103 dom_slice d =
104 let (y, m, o) = Date.gregorian d in
105 dom y m o
106
107 hour_slice :: Date -> Interval Date
108 hour_slice d =
109 let (y, m, o) = Date.gregorian d in
110 let Time.TimeOfDay h _ _ = tod d in
111 hour y m o h
112
113 minute_slice :: Date -> Interval Date
114 minute_slice d =
115 let (y, m, o) = Date.gregorian d in
116 let Time.TimeOfDay h n _ = tod d in
117 minute y m o h n
118
119 {-
120 second_slice :: Date -> Interval Date
121 second_slice d =
122 let (y, m, o) = Date.gregorian d in
123 let Time.TimeOfDay h n s = tod d in
124 second y m o h n s
125 -}