--------------------------------------------------------------- -- Copyright (c) 2013, Enzo Haussecker. All rights reserved. -- --------------------------------------------------------------- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS -Wall #-} {-# OPTIONS -fno-warn-name-shadowing #-} #include "MachDeps.h" module Data.Time.Exts.Unix ( Unix , UnixDate(..) , UnixDateTime(..) , UnixDateTimeMillis(..) , UnixDateTimeMicros(..) , UnixDateTimeNanos(..) , UnixDateTimePicos(..) , createUnixDate , createUnixDateTime , createUnixDateTimeMillis , createUnixDateTimeMicros , createUnixDateTimeNanos , createUnixDateTimePicos , getCurrentUnixDate , getCurrentUnixDateTime , getCurrentUnixDateTimeMillis , getCurrentUnixDateTimeMicros , getCurrentUnixDateTimeNanos , getCurrentUnixDateTimePicos ) where import Control.Arrow ((***), first) import Control.DeepSeq (NFData) import Data.Aeson (FromJSON, ToJSON) import Data.Convertible (Convertible(..), convert) import Data.Int (Int16, Int32, Int64) import Data.Label (mkLabels, modify) import Data.Time.Exts.Base import Data.Typeable (Typeable) import Foreign.C.Types (CInt(..)) import Foreign.Marshal.Utils (with) import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr) import Foreign.Storable (Storable(..)) import GHC.Generics (Generic) import System.Random (Random(..)) import Text.Printf (printf) class Unix x newtype UnixDate = UnixDate Int32 deriving (Eq,FromJSON,Generic,Integral,NFData,Num,Ord,Random,Real,Storable,ToJSON,Typeable) newtype UnixDateTime = UnixDateTime Int64 deriving (Eq,FromJSON,Generic,Integral,NFData,Num,Ord,Random,Real,Storable,ToJSON,Typeable) data UnixDateTimeMillis = UnixDateTimeMillis { _uni_mil_base :: {-# UNPACK #-} !Int64 -- ^ seconds since Unix epoch (excluding leap seconds) , _uni_mil_mill :: {-# UNPACK #-} !Int16 -- ^ millisecinds } deriving (Eq,Generic,Ord,Typeable) data UnixDateTimeMicros = UnixDateTimeMicros { _uni_mic_base :: {-# UNPACK #-} !Int64 -- ^ seconds since Unix epoch (excluding leap seconds) , _uni_mic_micr :: {-# UNPACK #-} !Int32 -- ^ microsecinds } deriving (Eq,Generic,Ord,Typeable) data UnixDateTimeNanos = UnixDateTimeNanos { _uni_nan_base :: {-# UNPACK #-} !Int64 -- ^ seconds since Unix epoch (excluding leap seconds) , _uni_nan_nano :: {-# UNPACK #-} !Int32 -- ^ nanosecinds } deriving (Eq,Generic,Ord,Typeable) data UnixDateTimePicos = UnixDateTimePicos { _uni_pic_base :: {-# UNPACK #-} !Int64 -- ^ seconds since Unix epoch (excluding leap seconds) , _uni_pic_pico :: {-# UNPACK #-} !Int64 -- ^ picosecinds } deriving (Eq,Generic,Ord,Typeable) data TimeOfDay = TimeOfDay { tod_base :: Int64 , tod_mic :: Int64 } instance Enum UnixDate where succ = flip plus $ Day 1 pred = flip plus . Day $ - 1 toEnum n | minBound <= day && day <= maxBound = day | otherwise = error "toEnum: out of range" where day = fromIntegral n fromEnum = fromIntegral instance Enum UnixDateTime where succ = flip plus $ Second 1 pred = flip plus . Second $ - 1 toEnum n | minBound <= sec && sec <= maxBound = sec | otherwise = error "toEnum: out of range" where sec = fromIntegral n #if WORD_SIZE_IN_BITS == 64 fromEnum = fromIntegral #endif mkLabels [''UnixDateTimeMicros ,''UnixDateTimeMillis ,''UnixDateTimeNanos ,''UnixDateTimePicos ] instance Bounded UnixDate where minBound = 0000000 maxBound = 2932896 instance Bounded UnixDateTime where minBound = 000000000000 maxBound = 253402300799 instance Bounded UnixDateTimeMillis where minBound = UnixDateTimeMillis 000000000000 000 maxBound = UnixDateTimeMillis 253402300799 999 instance Bounded UnixDateTimeMicros where minBound = UnixDateTimeMicros 000000000000 000000 maxBound = UnixDateTimeMicros 253402300799 999999 instance Bounded UnixDateTimeNanos where minBound = UnixDateTimeNanos 000000000000 000000000 maxBound = UnixDateTimeNanos 253402300799 999999999 instance Bounded UnixDateTimePicos where minBound = UnixDateTimePicos 000000000000 000000000000 maxBound = UnixDateTimePicos 253402300799 999999999999 instance Convertible UnixDateTime UnixDate where safeConvert = Right . fromIntegral . flip div 86400 instance Convertible UnixDateTimeMillis UnixDate where safeConvert = Right . fromIntegral . flip div 86400 . _uni_mil_base instance Convertible UnixDateTimeMicros UnixDate where safeConvert = Right . fromIntegral . flip div 86400 . _uni_mic_base instance Convertible UnixDateTimeNanos UnixDate where safeConvert = Right . fromIntegral . flip div 86400 . _uni_nan_base instance Convertible UnixDateTimePicos UnixDate where safeConvert = Right . fromIntegral . flip div 86400 . _uni_pic_base instance Date UnixDate where toDateStruct = decompUnixDate fromDateStruct DateStruct{..} = createUnixDate _d_year _d_mon _d_mday instance DateTime UnixDateTime where toDateTimeStruct = decompUnixDateTime fromDateTimeStruct DateTimeStruct{..} = createUnixDateTime _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec where sec = round _dt_sec :: Second instance DateTime UnixDateTimeMillis where toDateTimeStruct = decompUnixDateTimeMillis fromDateTimeStruct DateTimeStruct{..} = createUnixDateTimeMillis _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec mil where (sec, mil) = properFracMillis _dt_sec instance DateTime UnixDateTimeMicros where toDateTimeStruct = decompUnixDateTimeMicros fromDateTimeStruct DateTimeStruct{..} = createUnixDateTimeMicros _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec mic where (sec, mic) = properFracMicros _dt_sec instance DateTime UnixDateTimeNanos where toDateTimeStruct = decompUnixDateTimeNanos fromDateTimeStruct DateTimeStruct{..} = createUnixDateTimeNanos _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec nan where (sec, nan) = properFracNanos _dt_sec instance DateTime UnixDateTimePicos where toDateTimeStruct = decompUnixDateTimePicos fromDateTimeStruct DateTimeStruct{..} = createUnixDateTimePicos _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec pic where (sec, pic) = properFracPicos _dt_sec instance DateTimeMath UnixDate Day where timestamp `plus` days = if minBound <= date && date <= maxBound then date else error "plus: out of range" where date = timestamp + fromIntegral days instance DateTimeMath UnixDateTime Day where timestamp `plus` days = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = timestamp + fromIntegral days * 86400 instance DateTimeMath UnixDateTimeMillis Day where timestamp `plus` days = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_mil_base (+ fromIntegral days * 86400) timestamp instance DateTimeMath UnixDateTimeMicros Day where timestamp `plus` days = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_mic_base (+ fromIntegral days * 86400) timestamp instance DateTimeMath UnixDateTimeNanos Day where timestamp `plus` days = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_nan_base (+ fromIntegral days * 86400) timestamp instance DateTimeMath UnixDateTimePicos Day where timestamp `plus` days = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_pic_base (+ fromIntegral days * 86400) timestamp instance DateTimeMath UnixDateTime Hour where timestamp `plus` hour = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = timestamp + fromIntegral hour * 3600 instance DateTimeMath UnixDateTimeMillis Hour where timestamp `plus` hour = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_mil_base (+ fromIntegral hour * 3600) timestamp instance DateTimeMath UnixDateTimeMicros Hour where timestamp `plus` hour = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_mic_base (+ fromIntegral hour * 3600) timestamp instance DateTimeMath UnixDateTimeNanos Hour where timestamp `plus` hour = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_nan_base (+ fromIntegral hour * 3600) timestamp instance DateTimeMath UnixDateTimePicos Hour where timestamp `plus` hour = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_pic_base (+ fromIntegral hour * 3600) timestamp instance DateTimeMath UnixDateTime Minute where timestamp `plus` mins = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = timestamp + fromIntegral mins * 60 instance DateTimeMath UnixDateTimeMillis Minute where timestamp `plus` mins = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_mil_base (+ fromIntegral mins * 60) timestamp instance DateTimeMath UnixDateTimeMicros Minute where timestamp `plus` mins = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_mic_base (+ fromIntegral mins * 60) timestamp instance DateTimeMath UnixDateTimeNanos Minute where timestamp `plus` mins = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_nan_base (+ fromIntegral mins * 60) timestamp instance DateTimeMath UnixDateTimePicos Minute where timestamp `plus` mins = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_pic_base (+ fromIntegral mins * 60) timestamp instance DateTimeMath UnixDateTime Second where timestamp `plus` secs = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = timestamp + fromIntegral secs instance DateTimeMath UnixDateTimeMillis Second where timestamp `plus` secs = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_mil_base (+ fromIntegral secs) timestamp instance DateTimeMath UnixDateTimeMicros Second where timestamp `plus` secs = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_mic_base (+ fromIntegral secs) timestamp instance DateTimeMath UnixDateTimeNanos Second where timestamp `plus` secs = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_nan_base (+ fromIntegral secs) timestamp instance DateTimeMath UnixDateTimePicos Second where timestamp `plus` secs = if minBound <= time && time <= maxBound then time else error "plus: out of range" where time = modify uni_pic_base (+ fromIntegral secs) timestamp instance DateTimeMath UnixDateTimeMillis Millis where UnixDateTimeMillis{..} `plus` mils = if minBound <= time && time <= maxBound then time else error "plus: out of range" where msum = fromIntegral _uni_mil_mill + fromIntegral mils base = _uni_mil_base + msum `div` 1000 time = UnixDateTimeMillis base . fromIntegral $ msum `mod` 1000 instance DateTimeMath UnixDateTimeMicros Millis where UnixDateTimeMicros{..} `plus` mils = if minBound <= time && time <= maxBound then time else error "plus: out of range" where msum = fromIntegral _uni_mic_micr + fromIntegral mils * 1000 base = _uni_mic_base + msum `div` 1000000 time = UnixDateTimeMicros base . fromIntegral $ msum `mod` 1000000 instance DateTimeMath UnixDateTimeNanos Millis where UnixDateTimeNanos{..} `plus` mils = if minBound <= time && time <= maxBound then time else error "plus: out of range" where msum = fromIntegral _uni_nan_nano + fromIntegral mils * 1000000 base = _uni_nan_base + msum `div` 1000000000 time = UnixDateTimeNanos base . fromIntegral $ msum `mod` 1000000000 instance DateTimeMath UnixDateTimePicos Millis where UnixDateTimePicos{..} `plus` mils = if minBound <= time && time <= maxBound then time else error "plus: out of range" where psum = fromIntegral _uni_pic_pico + fromIntegral mils * 1000000000 base = _uni_pic_base + psum `div` 1000000000000 time = UnixDateTimePicos base . fromIntegral $ psum `mod` 1000000000000 instance DateTimeMath UnixDateTimeMicros Micros where UnixDateTimeMicros{..} `plus` mics = if minBound <= time && time <= maxBound then time else error "plus: out of range" where msum = fromIntegral _uni_mic_micr + fromIntegral mics base = _uni_mic_base + msum `div` 1000000 time = UnixDateTimeMicros base . fromIntegral $ msum `mod` 1000000 instance DateTimeMath UnixDateTimeNanos Micros where UnixDateTimeNanos{..} `plus` mics = if minBound <= time && time <= maxBound then time else error "plus: out of range" where msum = fromIntegral _uni_nan_nano + fromIntegral mics * 1000 base = _uni_nan_base + msum `div` 1000000000 time = UnixDateTimeNanos base . fromIntegral $ msum `mod` 1000000000 instance DateTimeMath UnixDateTimePicos Micros where UnixDateTimePicos{..} `plus` mics = if minBound <= time && time <= maxBound then time else error "plus: out of range" where psum = fromIntegral _uni_pic_pico + fromIntegral mics * 1000000 base = _uni_pic_base + psum `div` 1000000000000 time = UnixDateTimePicos base . fromIntegral $ psum `mod` 1000000000000 instance DateTimeMath UnixDateTimeNanos Nanos where UnixDateTimeNanos{..} `plus` nans = if minBound <= time && time <= maxBound then time else error "plus: out of range" where msum = fromIntegral _uni_nan_nano + fromIntegral nans base = _uni_nan_base + msum `div` 1000000000 time = UnixDateTimeNanos base . fromIntegral $ msum `mod` 1000000000 instance DateTimeMath UnixDateTimePicos Nanos where UnixDateTimePicos{..} `plus` nans = if minBound <= time && time <= maxBound then time else error "plus: out of range" where psum = fromIntegral _uni_pic_pico + fromIntegral nans * 1000 base = _uni_pic_base + psum `div` 1000000000000 time = UnixDateTimePicos base . fromIntegral $ psum `mod` 1000000000000 instance DateTimeMath UnixDateTimePicos Picos where UnixDateTimePicos{..} `plus` pics = if minBound <= time && time <= maxBound then time else error "plus: out of range" where psum = fromIntegral _uni_pic_pico + fromIntegral pics base = _uni_pic_base + psum `div` 1000000000000 time = UnixDateTimePicos base . fromIntegral $ psum `mod` 1000000000000 instance FromJSON UnixDateTimeMillis instance FromJSON UnixDateTimeMicros instance FromJSON UnixDateTimeNanos instance FromJSON UnixDateTimePicos instance NFData UnixDateTimeMillis instance NFData UnixDateTimeMicros instance NFData UnixDateTimeNanos instance NFData UnixDateTimePicos instance Pretty UnixDate where pretty = prettyUnixDate instance Pretty UnixDateTime where pretty = prettyUnixDateTime instance Pretty UnixDateTimeMillis where pretty = prettyUnixDateTime instance Pretty UnixDateTimeMicros where pretty = prettyUnixDateTime instance Pretty UnixDateTimeNanos where pretty = prettyUnixDateTime instance Pretty UnixDateTimePicos where pretty = prettyUnixDateTime instance Random UnixDateTimeMillis where random = first (uncurry UnixDateTimeMillis . (***) fromInteger fromInteger . flip divMod 1000) . randomR (0, 253402300799999) randomR (a, b) = first (uncurry UnixDateTimeMillis . (***) fromInteger fromInteger . flip divMod 1000) . randomR (minval, maxval) where minval = toInteger (_uni_mil_mill a) + toInteger (_uni_mil_base a) * 1000 maxval = toInteger (_uni_mil_mill b) + toInteger (_uni_mil_base b) * 1000 instance Random UnixDateTimeMicros where random = first (uncurry UnixDateTimeMicros . (***) fromInteger fromInteger . flip divMod 1000000) . randomR (0, 253402300799999999) randomR (a, b) = first (uncurry UnixDateTimeMicros . (***) fromInteger fromInteger . flip divMod 1000000) . randomR (minval, maxval) where minval = toInteger (_uni_mic_micr a) + toInteger (_uni_mic_base a) * 1000000 maxval = toInteger (_uni_mic_micr b) + toInteger (_uni_mic_base b) * 1000000 instance Random UnixDateTimeNanos where random = first (uncurry UnixDateTimeNanos . (***) fromInteger fromInteger . flip divMod 1000000000) . randomR (0, 253402300799999999999) randomR (a, b) = first (uncurry UnixDateTimeNanos . (***) fromInteger fromInteger . flip divMod 1000000000) . randomR (minval, maxval) where minval = toInteger (_uni_nan_nano a) + toInteger (_uni_nan_base a) * 1000000000 maxval = toInteger (_uni_nan_nano b) + toInteger (_uni_nan_base b) * 1000000000 instance Random UnixDateTimePicos where random = first (uncurry UnixDateTimePicos . (***) fromInteger fromInteger . flip divMod 1000000000000) . randomR (0, 253402300799999999999999) randomR (a, b) = first (uncurry UnixDateTimePicos . (***) fromInteger fromInteger . flip divMod 1000000000000) . randomR (minval, maxval) where minval = toInteger (_uni_pic_pico a) + toInteger (_uni_pic_base a) * 1000000000000 maxval = toInteger (_uni_pic_pico b) + toInteger (_uni_pic_base b) * 1000000000000 instance Show UnixDate where show date = printf "%04d-%02d-%02d" _d_year _d_mon _d_mday where DateStruct{..} = toDateStruct date instance Show UnixDateTime where show time = printf "%04d-%02d-%02d %02d:%02d:%02d" _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec where DateTimeStruct{..} = toDateTimeStruct time sec = round _dt_sec :: Second instance Show UnixDateTimeMillis where show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%03d" _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec mil where DateTimeStruct{..} = toDateTimeStruct time (sec, mil) = properFracMillis _dt_sec instance Show UnixDateTimeMicros where show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%06d" _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec mic where DateTimeStruct{..} = toDateTimeStruct time (sec, mic) = properFracMicros _dt_sec instance Show UnixDateTimeNanos where show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%09d" _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec nan where DateTimeStruct{..} = toDateTimeStruct time (sec, nan) = properFracNanos _dt_sec instance Show UnixDateTimePicos where show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%012d" _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec pic where DateTimeStruct{..} = toDateTimeStruct time (sec, pic) = properFracPicos _dt_sec instance Storable UnixDateTimeMillis where sizeOf _ = 10 alignment = sizeOf peekElemOff ptr n = do let off = 10 * n base <- peek . plusPtr ptr $ off mil <- peek . plusPtr ptr $ off + 8 return $! UnixDateTimeMillis base mil pokeElemOff ptr n UnixDateTimeMillis{..} = do let off = 10 * n poke (plusPtr ptr $ off ) _uni_mil_base poke (plusPtr ptr $ off + 8) _uni_mil_mill instance Storable UnixDateTimeMicros where sizeOf _ = 12 alignment = sizeOf peekElemOff ptr n = do let off = 12 * n base <- peek . plusPtr ptr $ off mic <- peek . plusPtr ptr $ off + 8 return $! UnixDateTimeMicros base mic pokeElemOff ptr n UnixDateTimeMicros{..} = do let off = 12 * n poke (plusPtr ptr $ off ) _uni_mic_base poke (plusPtr ptr $ off + 8) _uni_mic_micr instance Storable UnixDateTimeNanos where sizeOf _ = 12 alignment = sizeOf peekElemOff ptr n = do let off = 12 * n base <- peek . plusPtr ptr $ off nan <- peek . plusPtr ptr $ off + 8 return $! UnixDateTimeNanos base nan pokeElemOff ptr n UnixDateTimeNanos{..} = do let off = 12 * n poke (plusPtr ptr $ off ) _uni_nan_base poke (plusPtr ptr $ off + 8) _uni_nan_nano instance Storable UnixDateTimePicos where sizeOf _ = 16 alignment = sizeOf peekElemOff ptr n = do let off = 16 * n base <- peek . plusPtr ptr $ off pic <- peek . plusPtr ptr $ off + 8 return $! UnixDateTimePicos base pic pokeElemOff ptr n UnixDateTimePicos{..} = do let off = 16 * n poke (plusPtr ptr $ off ) _uni_pic_base poke (plusPtr ptr $ off + 8) _uni_pic_pico instance Storable TimeOfDay where sizeOf _ = 16 alignment = sizeOf peekElemOff ptr n = do let off = 16 * n base <- peek . plusPtr ptr $ off mic <- peek . plusPtr ptr $ off + 8 return $! TimeOfDay base mic pokeElemOff ptr n TimeOfDay{..} = do let off = 16 * n poke (plusPtr ptr $ off ) tod_base poke (plusPtr ptr $ off + 8) tod_mic instance ToJSON UnixDateTimeMillis instance ToJSON UnixDateTimeMicros instance ToJSON UnixDateTimeNanos instance ToJSON UnixDateTimePicos instance Unix UnixDate instance Unix UnixDateTime instance Unix UnixDateTimeMillis instance Unix UnixDateTimeMicros instance Unix UnixDateTimeNanos instance Unix UnixDateTimePicos foreign import ccall "gettimeofday" getTimeOfDay :: Ptr TimeOfDay -> Ptr () -> IO CInt -- | Creates a Unix date. createUnixDate :: Year -> Month -> Day -> UnixDate createUnixDate year month day = if minBound <= date && date <= maxBound then date else error "createUnixDate: date not supported" where date = fromIntegral $ epochToDate year month day -- | Creates a Unix date and time. createUnixDateTime :: Year -> Month -> Day -> Hour -> Minute -> Second -> UnixDateTime createUnixDateTime year month day hour minute second = if minBound <= time && time <= maxBound then time else error "createUnixDateTime: time not supported" where days = epochToDate year month day secs = dateToTime hour minute second time = fromIntegral days * 86400 + fromIntegral secs -- | Creates a Unix date and time with millisecond granularity. createUnixDateTimeMillis :: Year -> Month -> Day -> Hour -> Minute -> Second -> Millis -> UnixDateTimeMillis createUnixDateTimeMillis year month day hour minute second millisecond = if minBound <= time && time <= maxBound then time else error "createUnixDateTimeMillis: time not supported" where mils = fromIntegral $ millisecond `mod` 1000 adds = fromIntegral $ millisecond `div` 1000 days = fromIntegral $ epochToDate year month day secs = fromIntegral $ dateToTime hour minute second base = days * 86400 + secs + adds time = UnixDateTimeMillis base mils -- | Creates a Unix date and time with microsecond granularity. createUnixDateTimeMicros :: Year -> Month -> Day -> Hour -> Minute -> Second -> Micros -> UnixDateTimeMicros createUnixDateTimeMicros year month day hour minute second microsecond = if minBound <= time && time <= maxBound then time else error "createUnixDateTimeMicros: time not supported" where mics = fromIntegral $ microsecond `mod` 1000000 adds = fromIntegral $ microsecond `div` 1000000 days = fromIntegral $ epochToDate year month day secs = fromIntegral $ dateToTime hour minute second base = days * 86400 + secs + adds time = UnixDateTimeMicros base mics -- | Creates a Unix date and time with nanosecond granularity. createUnixDateTimeNanos :: Year -> Month -> Day -> Hour -> Minute -> Second -> Nanos -> UnixDateTimeNanos createUnixDateTimeNanos year month day hour minute second nanosecond = if minBound <= time && time <= maxBound then time else error "createUnixDateTimeNanos: time not supported" where nans = fromIntegral $ nanosecond `mod` 1000000000 adds = fromIntegral $ nanosecond `div` 1000000000 days = fromIntegral $ epochToDate year month day secs = fromIntegral $ dateToTime hour minute second base = days * 86400 + secs + adds time = UnixDateTimeNanos base nans -- | Creates a Unix date and time with picosecond granularity. createUnixDateTimePicos :: Year -> Month -> Day -> Hour -> Minute -> Second -> Picos -> UnixDateTimePicos createUnixDateTimePicos year month day hour minute second picosecond = if minBound <= time && time <= maxBound then time else error "createUnixDateTimePicos: time not supported" where pics = fromIntegral $ picosecond `mod` 1000000000000 adds = fromIntegral $ picosecond `div` 1000000000000 days = fromIntegral $ epochToDate year month day secs = fromIntegral $ dateToTime hour minute second base = days * 86400 + secs + adds time = UnixDateTimePicos base pics -- | Decomposes a Unix date into a human-readable format. decompUnixDate :: UnixDate -> DateStruct decompUnixDate date = go 1970 $ fromIntegral date where go :: Year -> Day -> DateStruct go !year !days = if days >= size then go (year + 1) (days - size) else DateStruct year month mday wday where wday = dayOfWeek date leap = isLeapYear year size = if leap then 366 else 365 (,) month mday = decompYearToDate days leap -- | Decomposes the number of days since January 1st into month and day components. decompYearToDate :: Day -> Bool -> (Month, Day) decompYearToDate days leap = if leap then if days >= 182 then if days >= 274 then if days >= 335 then (12, days - 334) else if days >= 305 then (11, days - 304) else (10, days - 273) else if days >= 244 then (09, days - 243) else if days >= 213 then (08, days - 212) else (07, days - 181) else if days >= 091 then if days >= 152 then (06, days - 151) else if days >= 121 then (05, days - 120) else (04, days - 090) else if days >= 060 then (03, days - 059) else if days >= 031 then (02, days - 030) else (01, days + 001) else if days >= 181 then if days >= 273 then if days >= 334 then (12, days - 333) else if days >= 304 then (11, days - 303) else (10, days - 272) else if days >= 243 then (09, days - 242) else if days >= 212 then (08, days - 211) else (07, days - 180) else if days >= 090 then if days >= 151 then (06, days - 150) else if days >= 120 then (05, days - 119) else (04, days - 089) else if days >= 059 then (03, days - 058) else if days >= 031 then (02, days - 030) else (01, days + 001) -- | Computes the day of the week. dayOfWeek :: UnixDate -> DayOfWeek dayOfWeek date = case date `mod` 7 of 0 -> Thursday 1 -> Friday 2 -> Saturday 3 -> Sunday 4 -> Monday 5 -> Tuesday _ -> Wednesday -- | Decomposes a Unix date and time into a human-readable format. decompUnixDateTime :: UnixDateTime -> DateTimeStruct decompUnixDateTime time = DateTimeStruct _d_year _d_mon _d_mday _d_wday hour min sec where DateStruct{..} = decompUnixDate date date = fromIntegral $ time `div` 86400 mod1 = fromIntegral $ time `mod` 86400 hour = fromIntegral $ mod1 `div` 03600 mod2 = mod1 `mod` 03600 min = mod2 `div` 00060 sec = fromIntegral $ mod2 `mod` 00060 -- | Decomposes a Unix date and time with millisecond granularity into a human-readable format. decompUnixDateTimeMillis :: UnixDateTimeMillis -> DateTimeStruct decompUnixDateTimeMillis UnixDateTimeMillis{..} = DateTimeStruct _d_year _d_mon _d_mday _d_wday hour min $ sec + frac where DateStruct{..} = decompUnixDate date date = fromIntegral $ time `div` 86400 mod1 = fromIntegral $ time `mod` 86400 hour = fromIntegral $ mod1 `div` 03600 mod2 = mod1 `mod` 03600 min = mod2 `div` 00060 sec = fromIntegral $ mod2 `mod` 00060 time = _uni_mil_base frac = fromIntegral _uni_mil_mill / 1000 -- | Decomposes a Unix date and time with microsecond granularity into a human-readable format. decompUnixDateTimeMicros :: UnixDateTimeMicros -> DateTimeStruct decompUnixDateTimeMicros UnixDateTimeMicros{..} = DateTimeStruct _d_year _d_mon _d_mday _d_wday hour min $ sec + frac where DateStruct{..} = decompUnixDate date date = fromIntegral $ time `div` 86400 mod1 = fromIntegral $ time `mod` 86400 hour = fromIntegral $ mod1 `div` 03600 mod2 = mod1 `mod` 03600 min = mod2 `div` 00060 sec = fromIntegral $ mod2 `mod` 00060 time = _uni_mic_base frac = fromIntegral _uni_mic_micr / 1000000 -- | Decomposes a Unix date and time with nanosecond granularity into a human-readable format. decompUnixDateTimeNanos :: UnixDateTimeNanos -> DateTimeStruct decompUnixDateTimeNanos UnixDateTimeNanos{..} = DateTimeStruct _d_year _d_mon _d_mday _d_wday hour min $ sec + frac where DateStruct{..} = decompUnixDate date date = fromIntegral $ base `div` 86400 mod1 = fromIntegral $ base `mod` 86400 hour = fromIntegral $ mod1 `div` 03600 mod2 = mod1 `mod` 03600 min = mod2 `div` 00060 sec = fromIntegral $ mod2 `mod` 00060 base = _uni_nan_base frac = fromIntegral _uni_nan_nano / 1000000000 -- | Decomposes a Unix date and time with picosecond granularity into a human-readable format. decompUnixDateTimePicos :: UnixDateTimePicos -> DateTimeStruct decompUnixDateTimePicos UnixDateTimePicos{..} = DateTimeStruct _d_year _d_mon _d_mday _d_wday hour min $ sec + frac where DateStruct{..} = decompUnixDate date date = fromIntegral $ base `div` 86400 mod1 = fromIntegral $ base `mod` 86400 hour = fromIntegral $ mod1 `div` 03600 mod2 = mod1 `mod` 03600 min = mod2 `div` 00060 sec = fromIntegral $ mod2 `mod` 00060 base = _uni_pic_base frac = fromIntegral _uni_pic_pico / 1000000000000 -- | Gets the current Unix date from the system clock. getCurrentUnixDate :: IO UnixDate getCurrentUnixDate = getCurrentUnixDateTime >>= return . convert -- | Gets the current Unix date and time from the system clock. getCurrentUnixDateTime :: IO UnixDateTime getCurrentUnixDateTime = with (TimeOfDay 0 0) $ \ ptr -> getTimeOfDay ptr nullPtr >>= getResult ptr where getResult ptr 0 = peek $ castPtr ptr getResult _ _ = error "getCurrentUnixDateTime: unknown" -- | Gets the current Unix date and time with millisecond granularity from the system clock. getCurrentUnixDateTimeMillis :: IO UnixDateTimeMillis getCurrentUnixDateTimeMillis = with (TimeOfDay 0 0) $ \ ptr -> getTimeOfDay ptr nullPtr >>= getResult ptr where getResult ptr 0 = peek ptr >>= \ TimeOfDay{..} -> return $! UnixDateTimeMillis tod_base . fromIntegral $ tod_mic `div` 1000 getResult _ _ = error "getCurrentUnixDateTimeMillis: unknown" -- | Gets the current Unix date and time with microsecond granularity from the system clock. getCurrentUnixDateTimeMicros :: IO UnixDateTimeMicros getCurrentUnixDateTimeMicros = with (TimeOfDay 0 0) $ \ ptr -> getTimeOfDay ptr nullPtr >>= getResult ptr where getResult ptr 0 = peek ptr >>= \ TimeOfDay{..} -> return $! UnixDateTimeMicros tod_base $ fromIntegral tod_mic getResult _ _ = error "getCurrentUnixDateTimeMicros: unknown" -- | Gets the current Unix date and time with nanosecond granularity from the system clock. getCurrentUnixDateTimeNanos :: IO UnixDateTimeNanos getCurrentUnixDateTimeNanos = with (TimeOfDay 0 0) $ \ ptr -> getTimeOfDay ptr nullPtr >>= getResult ptr where getResult ptr 0 = peek ptr >>= \ TimeOfDay{..} -> return $! UnixDateTimeNanos tod_base $ fromIntegral tod_mic * 1000 getResult _ _ = error "getCurrentUnixDateTimeNanos: unknown" -- | Gets the current Unix date and time with picosecond granularity from the system clock. getCurrentUnixDateTimePicos :: IO UnixDateTimePicos getCurrentUnixDateTimePicos = with (TimeOfDay 0 0) $ \ ptr -> getTimeOfDay ptr nullPtr >>= getResult ptr where getResult ptr 0 = peek ptr >>= \ TimeOfDay{..} -> return $! UnixDateTimePicos tod_base $ fromIntegral tod_mic * 1000000 getResult _ _ = error "getCurrentUnixDateTimePicos: unknown" -- | Shows a Unix date as a string. prettyUnixDate :: UnixDate -> String prettyUnixDate date = printf "%s, %s %s, %04d" wday mon mday _d_year where DateStruct{..} = toDateStruct date wday = show _d_wday mon = prettyMonth _d_mon mday = prettyDay _d_mday -- | Shows a Unix date and time as a string. prettyUnixDateTime :: DateTime dt => dt -> String prettyUnixDateTime time = printf str hour _dt_min ampm wday mon mday _dt_year where DateTimeStruct{..} = toDateTimeStruct time str = "%d:%02d %s, %s, %s %s, %04d" wday = show _dt_wday mon = prettyMonth _dt_mon mday = prettyDay _dt_mday (hour, ampm) = prettyHour _dt_hour