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