]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Date.hs
Ajout : syntax/ledger.vim : ledgerChart.
[comptalang.git] / lib / Hcompta / Date.hs
1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 module Hcompta.Date where
3
4 import Control.Monad (Monad(..))
5 import qualified Data.Fixed
6 import Data.Maybe (Maybe(..))
7 import qualified Data.Time.Calendar as Time
8 import qualified Data.Time.Clock as Time
9 import qualified Data.Time.Clock.POSIX as Time (posixSecondsToUTCTime)
10 import qualified Data.Time.Format as Time ()
11 import qualified Data.Time.LocalTime as Time
12 import Prelude ( ($)
13 , (.)
14 , IO
15 , Int
16 , Integer
17 , Num(..)
18 , id
19 )
20
21 -- * Type 'Date'
22
23 type Date = Time.UTCTime
24 type Year = Integer
25 type Month = Int
26 type Day = Time.Day
27 type DoM = Int
28 type Hour = Int
29 type Minute = Int
30 type Second = Data.Fixed.Pico
31
32 nil :: Date
33 nil = Time.posixSecondsToUTCTime 0
34
35 now :: IO Date
36 now = Time.getCurrentTime
37
38 date :: Year -> Month -> DoM -> Hour -> Minute -> Second -> Maybe Date
39 date y m d h mn s = do
40 gday <- Time.fromGregorianValid y m d
41 hod <- Time.makeTimeOfDayValid h mn s
42 return $
43 Time.UTCTime gday $
44 Time.timeOfDayToTime hod
45
46 -- ** Components
47
48 gregorian :: Date -> (Year, Month, DoM)
49 gregorian = Time.toGregorian . Time.utctDay
50
51 year :: Date -> Year
52 year = (\(x, _, _) -> x) . gregorian
53
54 month :: Date -> Month
55 month = (\(_, x, _) -> x) . gregorian
56
57 day :: Date -> Day
58 day = Time.utctDay
59
60 dom :: Date -> DoM
61 dom = (\(_, _, x) -> x) . gregorian
62
63 tod :: Date -> Time.TimeOfDay
64 tod = Time.timeToTimeOfDay . Time.utctDayTime
65
66 hour :: Date -> Hour
67 hour = (\(Time.TimeOfDay x _ _) -> x) . tod
68
69 minute :: Date -> Minute
70 minute = (\(Time.TimeOfDay _ x _) -> x) . tod
71
72 second :: Date -> Second
73 second = (\(Time.TimeOfDay _ _ x) -> x) . tod
74
75 next_year_start :: Date -> Date
76 next_year_start d =
77 nil{ Time.utctDay =
78 Time.addGregorianYearsClip
79 (year d + 1 - 1970)
80 (Time.utctDay d)
81 }
82
83 utc :: Date -> Time.UTCTime
84 utc = id
85
86 bench :: IO a -> IO (a, Time.NominalDiffTime)
87 bench m = do
88 t0 <- now
89 r <- m
90 t1 <- now
91 return (r, Time.diffUTCTime t1 t0)
92
93 {-
94 data Interval
95 = Interval_None
96 | Interval_Days Int
97 | Interval_Weeks Int
98 | Interval_Months Int
99 | Interval_Quarters Int
100 | Interval_Years Int
101 | Interval_DayOfMonth Int
102 | Interval_DayOfWeek Int
103 -- Interval_WeekOfYear Int
104 -- Interval_MonthOfYear Int
105 -- Interval_QuarterOfYear Int
106 deriving (Data, Eq, Ord, Read, Show, Typeable)
107
108
109 type Smart
110 = (String, String, String)
111 data Which
112 = Which_Primary
113 | Which_Secondary
114 deriving (Eq, Read, Show)
115 -}