]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Date.hs
Use symantic-document instead of walderleijen-ansi-text.
[comptalang.git] / lib / Hcompta / Date.hs
1 module Hcompta.Date where
2
3 import Control.Monad (Monad(..))
4 import qualified Data.Fixed
5 import Data.Function (($), (.), id)
6 import Data.Int (Int)
7 import Data.Maybe (Maybe(..))
8 import qualified Data.Time.Calendar as Time
9 import qualified Data.Time.Clock as Time
10 import qualified Data.Time.Clock.POSIX as Time (posixSecondsToUTCTime)
11 import qualified Data.Time.Format as Time ()
12 import qualified Data.Time.LocalTime as Time
13 import Prelude (Integer, Num(..))
14 import System.IO (IO)
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 date_epoch :: d
26 date_now :: IO d
27 date_gregorian :: d -> (Date_Year d, Date_Month d, Date_DoM d)
28 date_year :: d -> Date_Year d
29 date_month :: d -> Date_Month d
30 date_dom :: d -> Date_DoM d
31 date_tod :: d -> (Date_Hour d, Date_Minute d, Date_Second d)
32 date_hour :: d -> Date_Hour d
33 date_minute :: d -> Date_Minute d
34 date_second :: d -> Date_Second d
35 date_utc :: d -> Time.UTCTime
36 date_from
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 date_year = (\(x, _, _) -> x) . date_gregorian
46 date_month = (\(_, x, _) -> x) . date_gregorian
47 date_dom = (\(_, _, x) -> x) . date_gregorian
48 date_hour = (\(x, _, _) -> x) . date_tod
49 date_minute = (\(_, x, _) -> x) . date_tod
50 date_second = (\(_, _, x) -> x) . date_tod
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 date_epoch = Time.posixSecondsToUTCTime 0
60 date_now = Time.getCurrentTime
61 date_gregorian = Time.toGregorian . Time.utctDay
62 date_tod d =
63 case Time.timeToTimeOfDay $ Time.utctDayTime d of
64 Time.TimeOfDay h m s -> (h, m, s)
65 -- date_day = Time.utctDay
66 date_utc = id
67 date_from 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 date_epoch{ Time.utctDay =
77 Time.addGregorianYearsClip
78 (date_year 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 <- date_now
85 r <- m
86 t1 <- date_now
87 return (r, Time.diffUTCTime t1 t0)