module Hcompta.Date where import Control.Monad (Monad(..)) import Data.Function (($), (.), id) import Data.Int (Int) import Data.Maybe (Maybe(..)) import Prelude (Integer, Num(..)) import System.IO (IO) import qualified Data.Fixed import qualified Data.Time.Calendar as Time import qualified Data.Time.Clock as Time import qualified Data.Time.Clock.POSIX as Time (posixSecondsToUTCTime) import qualified Data.Time.Format as Time () import qualified Data.Time.LocalTime as Time -- * Class 'Date' class Date d where type Date_Year d type Date_Month d type Date_DoM d type Date_Hour d type Date_Minute d type Date_Second d epoch :: d now :: IO d gregorianOf :: d -> (Date_Year d, Date_Month d, Date_DoM d) yearOf :: d -> Date_Year d monthOf :: d -> Date_Month d domOf :: d -> Date_DoM d todOf :: d -> (Date_Hour d, Date_Minute d, Date_Second d) hourOf :: d -> Date_Hour d minuteOf :: d -> Date_Minute d secondOf :: d -> Date_Second d utcOf :: d -> Time.UTCTime dateOf :: Date_Year d -> Date_Month d -> Date_DoM d -> Date_Hour d -> Date_Minute d -> Date_Second d -> Maybe d yearOf = (\(x, _, _) -> x) . gregorianOf monthOf = (\(_, x, _) -> x) . gregorianOf domOf = (\(_, _, x) -> x) . gregorianOf hourOf = (\(x, _, _) -> x) . todOf minuteOf = (\(_, x, _) -> x) . todOf secondOf = (\(_, _, x) -> x) . todOf instance Date Time.UTCTime where type Date_Year Time.UTCTime = Integer type Date_Month Time.UTCTime = Int type Date_DoM Time.UTCTime = Int type Date_Hour Time.UTCTime = Int type Date_Minute Time.UTCTime = Int type Date_Second Time.UTCTime = Data.Fixed.Pico epoch = Time.posixSecondsToUTCTime 0 now = Time.getCurrentTime gregorianOf = Time.toGregorian . Time.utctDay todOf d = case Time.timeToTimeOfDay $ Time.utctDayTime d of Time.TimeOfDay h m s -> (h, m, s) -- date_day = Time.utctDay utcOf = id dateOf y m d h mn s = do gday <- Time.fromGregorianValid y m d hod <- Time.makeTimeOfDayValid h mn s return $ Time.UTCTime gday $ Time.timeOfDayToTime hod date_next_year_start :: Time.UTCTime -> Time.UTCTime date_next_year_start d = epoch{ Time.utctDay = Time.addGregorianYearsClip (yearOf d + 1 - 1970) (Time.utctDay d) } date_bench :: IO a -> IO (a, Time.NominalDiffTime) date_bench m = do t0 <- now r <- m t1 <- now return (r, Time.diffUTCTime t1 t0)