]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Date.hs
Remove cli/
[comptalang.git] / lib / Hcompta / Date.hs
1 module Hcompta.Date where
2
3 import Control.Monad (Monad(..))
4 import Data.Function (($), (.), id)
5 import Data.Int (Int)
6 import Data.Maybe (Maybe(..))
7 import Prelude (Integer, Num(..))
8 import System.IO (IO)
9 import qualified Data.Fixed
10 import qualified Data.Time.Calendar as Time
11 import qualified Data.Time.Clock as Time
12 import qualified Data.Time.Clock.POSIX as Time (posixSecondsToUTCTime)
13 import qualified Data.Time.Format as Time ()
14 import qualified Data.Time.LocalTime as Time
15
16 -- * Class 'Date'
17 class Date d where
18 type Date_Year d
19 type Date_Month d
20 type Date_DoM d
21 type Date_Hour d
22 type Date_Minute d
23 type Date_Second d
24
25 epoch :: d
26 now :: IO d
27 gregorianOf :: d -> (Date_Year d, Date_Month d, Date_DoM d)
28 yearOf :: d -> Date_Year d
29 monthOf :: d -> Date_Month d
30 domOf :: d -> Date_DoM d
31 todOf :: d -> (Date_Hour d, Date_Minute d, Date_Second d)
32 hourOf :: d -> Date_Hour d
33 minuteOf :: d -> Date_Minute d
34 secondOf :: d -> Date_Second d
35 utcOf :: d -> Time.UTCTime
36 dateOf
37 :: Date_Year d
38 -> Date_Month d
39 -> Date_DoM d
40 -> Date_Hour d
41 -> Date_Minute d
42 -> Date_Second d
43 -> Maybe d
44
45 yearOf = (\(x, _, _) -> x) . gregorianOf
46 monthOf = (\(_, x, _) -> x) . gregorianOf
47 domOf = (\(_, _, x) -> x) . gregorianOf
48 hourOf = (\(x, _, _) -> x) . todOf
49 minuteOf = (\(_, x, _) -> x) . todOf
50 secondOf = (\(_, _, x) -> x) . todOf
51
52 instance Date Time.UTCTime where
53 type Date_Year Time.UTCTime = Integer
54 type Date_Month Time.UTCTime = Int
55 type Date_DoM Time.UTCTime = Int
56 type Date_Hour Time.UTCTime = Int
57 type Date_Minute Time.UTCTime = Int
58 type Date_Second Time.UTCTime = Data.Fixed.Pico
59 epoch = Time.posixSecondsToUTCTime 0
60 now = Time.getCurrentTime
61 gregorianOf = Time.toGregorian . Time.utctDay
62 todOf d =
63 case Time.timeToTimeOfDay $ Time.utctDayTime d of
64 Time.TimeOfDay h m s -> (h, m, s)
65 -- date_day = Time.utctDay
66 utcOf = id
67 dateOf y m d h mn s = do
68 gday <- Time.fromGregorianValid y m d
69 hod <- Time.makeTimeOfDayValid h mn s
70 return $
71 Time.UTCTime gday $
72 Time.timeOfDayToTime hod
73
74 date_next_year_start :: Time.UTCTime -> Time.UTCTime
75 date_next_year_start d =
76 epoch{ Time.utctDay =
77 Time.addGregorianYearsClip
78 (yearOf d + 1 - 1970)
79 (Time.utctDay d)
80 }
81
82 date_bench :: IO a -> IO (a, Time.NominalDiffTime)
83 date_bench m = do
84 t0 <- now
85 r <- m
86 t1 <- now
87 return (r, Time.diffUTCTime t1 t0)