diff --git a/src/Data/Time/Exts/Local.hs b/src/Data/Time/Exts/Local.hs --- a/src/Data/Time/Exts/Local.hs +++ b/src/Data/Time/Exts/Local.hs @@ -1145,7 +1145,7 @@ instance Duration LocalDateTimePicos Nanos where duration old new = - if res < toInteger (maxBound::Int64) then Nanos $ fromInteger res + if res < toInteger (maxBound::Int64) then Nanos $ fromInteger res `div` 1000 else error "duration{LocalDateTimePicos,Nanos}: integer overflow" where res = fromLocalDateTimePicos new - fromLocalDateTimePicos old diff --git a/src/Data/Time/Exts/Unix b/src/Data/Time/Exts/Unix new file mode 100644 --- /dev/null +++ b/src/Data/Time/Exts/Unix @@ -0,0 +1,875 @@ +--------------------------------------------------------------- +-- Copyright (c) 2014, Enzo Haussecker. All rights reserved. -- +--------------------------------------------------------------- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS -Wall #-} + +-- | Unix timestamps of varying granularity. +module Data.Time.Exts.Unix ( + + -- ** Unix Class + Unix(..) + + -- ** Unix Timestamps + , UnixDate(..) + , UnixDateTime(..) + , UnixDateTimeMillis(..) + , UnixDateTimeMicros(..) + , UnixDateTimeNanos(..) + , UnixDateTimePicos(..) + + -- ** Create Unix Timestamps + , createUnixDate + , createUnixDateTime + , createUnixDateTimeMillis + , createUnixDateTimeMicros + , createUnixDateTimeNanos + , createUnixDateTimePicos + + -- ** Get Current Unix Timestamps + , getCurrentUnixDate + , getCurrentUnixDateTime + , getCurrentUnixDateTimeMillis + , getCurrentUnixDateTimeMicros + , getCurrentUnixDateTimeNanos + , getCurrentUnixDateTimePicos + + -- ** Pretty Unix Timestamps + , prettyUnixDate + , prettyUnixDateTime + + ) 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 (get, mkLabels, modify) +import Data.Time.Exts.Base +import Data.Time.Exts.C +import Data.Typeable (Typeable) +import Foreign.C.Types (CLong(..)) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (castPtr, nullPtr, plusPtr) +import Foreign.Storable (Storable(..)) +import GHC.Generics (Generic) +import System.Random (Random(..)) +import Text.Printf (printf) + +-- | The Unix timestamp type class. +class Unix u where + + -- | Get the base component of a Unix timestamp. + unixBase :: u -> Int64 + +-- | Days since Unix epoch. +newtype UnixDate = UnixDate { + _uni_day_base :: Int32 + } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable) + +-- | Seconds since Unix epoch (excluding leap seconds). +newtype UnixDateTime = UnixDateTime { + _uni_sec_base :: Int64 + } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable) + +-- | Milliseconds since Unix epoch (excluding leap seconds). +newtype UnixDateTimeMillis = UnixDateTimeMillis { + _uni_mil_base :: Int64 + } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable) + +-- | Microseconds since Unix epoch (excluding leap seconds). +newtype UnixDateTimeMicros = UnixDateTimeMicros { + _uni_mic_base :: Int64 + } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable) + +-- | Nanoseconds since Unix epoch (excluding leap seconds). +data UnixDateTimeNanos = UnixDateTimeNanos { + _uni_nan_base :: {-# UNPACK #-} !Int64 + , _uni_nan_nano :: {-# UNPACK #-} !Int16 + } deriving (Eq,Generic,Ord,Typeable) + +-- | Picoseconds since Unix epoch (excluding leap seconds). +data UnixDateTimePicos = UnixDateTimePicos { + _uni_pic_base :: {-# UNPACK #-} !Int64 + , _uni_pic_pico :: {-# UNPACK #-} !Int32 + } deriving (Eq,Generic,Ord,Typeable) + +instance FromJSON UnixDateTimeNanos +instance FromJSON UnixDateTimePicos + +instance NFData UnixDateTimeNanos +instance NFData UnixDateTimePicos + +instance Storable UnixDateTimeNanos where + sizeOf _ = 10 + alignment = sizeOf + peekElemOff ptr n = do + let off = 10 * n + base <- peek . plusPtr ptr $ off + nano <- peek . plusPtr ptr $ off + 8 + return $! UnixDateTimeNanos base nano + pokeElemOff ptr n UnixDateTimeNanos{..} = do + let off = 10 * n + poke (plusPtr ptr $ off ) _uni_nan_base + poke (plusPtr ptr $ off + 8) _uni_nan_nano + +instance Storable UnixDateTimePicos where + sizeOf _ = 12 + alignment = sizeOf + peekElemOff ptr n = do + let off = 12 * n + base <- peek . plusPtr ptr $ off + pico <- peek . plusPtr ptr $ off + 8 + return $! UnixDateTimePicos base pico + pokeElemOff ptr n UnixDateTimePicos{..} = do + let off = 12 * n + poke (plusPtr ptr $ off ) _uni_pic_base + poke (plusPtr ptr $ off + 8) _uni_pic_pico + +instance ToJSON UnixDateTimeNanos +instance ToJSON UnixDateTimePicos + +mkLabels [ ''DateTimeStruct + , ''UnixDate + , ''UnixDateTime + , ''UnixDateTimeMillis + , ''UnixDateTimeMicros + , ''UnixDateTimeNanos + , ''UnixDateTimePicos + ] + +instance Bounded UnixDate where + minBound = UnixDate 0 + maxBound = UnixDate 2932896 + +instance Bounded UnixDateTime where + minBound = UnixDateTime 0 + maxBound = UnixDateTime 253402300799 + +instance Bounded UnixDateTimeMillis where + minBound = UnixDateTimeMillis 0 + maxBound = UnixDateTimeMillis 253402300799999 + +instance Bounded UnixDateTimeMicros where + minBound = UnixDateTimeMicros 0 + maxBound = UnixDateTimeMicros 253402300799999999 + +instance Bounded UnixDateTimeNanos where + minBound = UnixDateTimeNanos 0 0 + maxBound = UnixDateTimeNanos 253402300799999999 999 + +instance Bounded UnixDateTimePicos where + minBound = UnixDateTimePicos 0 0 + maxBound = UnixDateTimePicos 253402300799999999 999999 + +instance Unix UnixDate where + unixBase = fromIntegral . get uni_day_base + +instance Unix UnixDateTime where + unixBase = get uni_sec_base + +instance Unix UnixDateTimeMillis where + unixBase = get uni_mil_base + +instance Unix UnixDateTimeMicros where + unixBase = get uni_mic_base + +instance Unix UnixDateTimeNanos where + unixBase = get uni_nan_base + +instance Unix UnixDateTimePicos where + unixBase = get uni_pic_base + +instance DateTimeMath UnixDate Day where + date `plus` Day day = + check "plus{UnixDate,Day}" $ + modify uni_day_base (+ day) date + +instance DateTimeMath UnixDateTime Day where + time `plus` Day day = + check "plus{UnixDateTime,Day}" $ + modify uni_sec_base (+ fromIntegral day * 86400) time + +instance DateTimeMath UnixDateTimeMillis Day where + time `plus` Day day = + check "plus{UnixDateTimeMillis,Day}" $ + modify uni_mil_base (+ fromIntegral day * 86400000) time + +instance DateTimeMath UnixDateTimeMicros Day where + time `plus` Day day = + check "plus{UnixDateTimeMicros,Day}" $ + modify uni_mic_base (+ fromIntegral day * 86400000000) time + +instance DateTimeMath UnixDateTimeNanos Day where + time `plus` Day day = + check "plus{UnixDateTimeNanos,Day}" $ + modify uni_nan_base (+ fromIntegral day * 86400000000) time + +instance DateTimeMath UnixDateTimePicos Day where + time `plus` Day day = + check "plus{UnixDateTimePicos,Day}" $ + modify uni_pic_base (+ fromIntegral day * 86400000000) time + +instance DateTimeMath UnixDateTime Hour where + time `plus` Hour hour = + check "plus{UnixDateTime,Hour}" $ + modify uni_sec_base (+ hour * 3600) time + +instance DateTimeMath UnixDateTimeMillis Hour where + time `plus` Hour hour = + check "plus{UnixDateTimeMillis,Hour}" $ + modify uni_mil_base (+ hour * 3600000) time + +instance DateTimeMath UnixDateTimeMicros Hour where + time `plus` Hour hour = + check "plus{UnixDateTimeMicros,Hour}" $ + modify uni_mic_base (+ hour * 3600000000) time + +instance DateTimeMath UnixDateTimeNanos Hour where + time `plus` Hour hour = + check "plus{UnixDateTimeNanos,Hour}" $ + modify uni_nan_base (+ hour * 3600000000) time + +instance DateTimeMath UnixDateTimePicos Hour where + time `plus` Hour hour = + check "plus{UnixDateTimePicos,Hour}" $ + modify uni_pic_base (+ hour * 3600000000) time + +instance DateTimeMath UnixDateTime Minute where + time `plus` Minute minute = + check "plus{UnixDateTime,Minute}" $ + modify uni_sec_base (+ minute * 60) time + +instance DateTimeMath UnixDateTimeMillis Minute where + time `plus` Minute minute = + check "plus{UnixDateTimeMillis,Minute}" $ + modify uni_mil_base (+ minute * 60000) time + +instance DateTimeMath UnixDateTimeMicros Minute where + time `plus` Minute minute = + check "plus{UnixDateTimeMicros,Minute}" $ + modify uni_mic_base (+ minute * 60000000) time + +instance DateTimeMath UnixDateTimeNanos Minute where + time `plus` Minute minute = + check "plus{UnixDateTimeNanos,Minute}" $ + modify uni_nan_base (+ minute * 60000000) time + +instance DateTimeMath UnixDateTimePicos Minute where + time `plus` Minute minute = + check "plus{UnixDateTimePicos,Minute}" $ + modify uni_pic_base (+ minute * 60000000) time + +instance DateTimeMath UnixDateTime Second where + time `plus` Second second = + check "plus{UnixDateTime,Second}" $ + modify uni_sec_base (+ second) time + +instance DateTimeMath UnixDateTimeMillis Second where + time `plus` Second second = + check "plus{UnixDateTimeMillis,Second}" $ + modify uni_mil_base (+ second * 1000) time + +instance DateTimeMath UnixDateTimeMicros Second where + time `plus` Second second = + check "plus{UnixDateTimeMicros,Second}" $ + modify uni_mic_base (+ second * 1000000) time + +instance DateTimeMath UnixDateTimeNanos Second where + time `plus` Second second = + check "plus{UnixDateTimeNanos,Second}" $ + modify uni_nan_base (+ second * 1000000) time + +instance DateTimeMath UnixDateTimePicos Second where + time `plus` Second second = + check "plus{UnixDateTimePicos,Second}" $ + modify uni_pic_base (+ second * 1000000) time + +instance DateTimeMath UnixDateTimeMillis Millis where + time `plus` Millis millis = + check "plus{UnixDateTimeMillis,Millis}" $ + modify uni_mil_base (+ millis) time + +instance DateTimeMath UnixDateTimeMicros Millis where + time `plus` Millis millis = + check "plus{UnixDateTimeMicros,Millis}" $ + modify uni_mic_base (+ millis * 1000) time + +instance DateTimeMath UnixDateTimeNanos Millis where + time `plus` Millis millis = + check "plus{UnixDateTimeNanos,Millis}" $ + modify uni_nan_base (+ millis * 1000) time + +instance DateTimeMath UnixDateTimePicos Millis where + time `plus` Millis millis = + check "plus{UnixDateTimePicos,Millis}" $ + modify uni_pic_base (+ millis * 1000) time + +instance DateTimeMath UnixDateTimeMicros Micros where + time `plus` Micros micros = + check "plus{UnixDateTimeMicros,Micros}" $ + modify uni_mic_base (+ micros) time + +instance DateTimeMath UnixDateTimeNanos Micros where + time `plus` Micros micros = + check "plus{UnixDateTimeNanos,Micros}" $ + modify uni_nan_base (+ micros) time + +instance DateTimeMath UnixDateTimePicos Micros where + time `plus` Micros micros = + check "plus{UnixDateTimePicos,Micros}" $ + modify uni_pic_base (+ micros) time + +instance DateTimeMath UnixDateTimeNanos Nanos where + UnixDateTimeNanos{..} `plus` Nanos nanos = + check "plus{UnixDateTimeNanos,Nanos}" . + uncurry UnixDateTimeNanos . + both (+ _uni_nan_base) fromIntegral . + flip divMod 1000 $ + fromIntegral _uni_nan_nano + nanos + +instance DateTimeMath UnixDateTimePicos Nanos where + UnixDateTimePicos{..} `plus` Nanos nanos = + check "plus{UnixDateTimePicos,Nanos}" . + uncurry UnixDateTimePicos . + both (+ _uni_pic_base) fromIntegral . + flip divMod 1000000 $ + fromIntegral _uni_pic_pico + nanos * 1000 + +instance DateTimeMath UnixDateTimePicos Picos where + UnixDateTimePicos{..} `plus` Picos picos = + check "plus{UnixDateTimePicos,Picos}" . + uncurry UnixDateTimePicos . + both (+ _uni_pic_base) fromIntegral . + flip divMod 1000000 $ + fromIntegral _uni_pic_pico + picos + +instance Enum UnixDate where + succ = flip plus $ Day 1 + pred = flip plus . Day $ - 1 + toEnum = check "toEnum{UnixDate}" . UnixDate . fromIntegral + fromEnum = fromIntegral . _uni_day_base + +instance Enum UnixDateTime where + succ = flip plus $ Second 1 + pred = flip plus . Second $ - 1 + toEnum = check "toEnum{UnixDateTime}" . UnixDateTime . fromIntegral + fromEnum = fromIntegral . _uni_sec_base + +instance Enum UnixDateTimeMillis where + succ = flip plus $ Millis 1 + pred = flip plus . Millis $ - 1 + toEnum = check "toEnum{UnixDateTimeMillis}" . UnixDateTimeMillis . fromIntegral + fromEnum = fromIntegral . _uni_mil_base + +instance Enum UnixDateTimeMicros where + succ = flip plus $ Micros 1 + pred = flip plus . Micros $ - 1 + toEnum = check "toEnum{UnixDateTimeMicros}" . UnixDateTimeMicros . fromIntegral + fromEnum = fromIntegral . _uni_mic_base + +-- | Create a Unix date. +-- +-- > >>> createUnixDate 2013 November 03 +-- > 2013-11-03 +-- +createUnixDate :: Year -> Month -> Day -> UnixDate +createUnixDate year month day = + check "createUnixDate" $ UnixDate base + where Day base = epochToDate year month day + +-- | Create a Unix date and time. +-- +-- > >>> createUnixDateTime 2012 April 27 07 37 30 +-- > 2012-04-27 07:37:30 +-- +createUnixDateTime :: Year -> Month -> Day -> Hour -> Minute -> Second -> UnixDateTime +createUnixDateTime year month day hour minute second = + check "createUnixDateTime" $ UnixDateTime base + where Second base = epochToTime year month day hour minute second + +-- | Create a Unix date and time with millisecond granularity. +-- +-- > >>> createUnixDateTimeMillis 2014 February 02 08 52 37 983 +-- > 2014-02-02 08:52:37.983 +-- +createUnixDateTimeMillis :: Year -> Month -> Day -> Hour -> Minute -> Second -> Millis -> UnixDateTimeMillis +createUnixDateTimeMillis year month day hour minute second (Millis millis) = + check "createUnixDateTimeMillis" $ UnixDateTimeMillis base + where Second seconds = epochToTime year month day hour minute second + base = seconds * 1000 + millis + +-- | Create a Unix date and time with microsecond granularity. +-- +-- > >>> createUnixDateTimeMicros 2011 January 22 17 34 13 138563 +-- > 2011-01-22 17:34:13.138563 +-- +createUnixDateTimeMicros :: Year -> Month -> Day -> Hour -> Minute -> Second -> Micros -> UnixDateTimeMicros +createUnixDateTimeMicros year month day hour minute second (Micros micros) = + check "createUnixDateTimeMicros" $ UnixDateTimeMicros base + where Second seconds = epochToTime year month day hour minute second + base = seconds * 1000000 + micros + +-- | Create a Unix date and time with nanosecond granularity. +-- +-- > >>> createUnixDateTimeNanos 2012 June 28 01 30 35 688279651 +-- > 2012-06-28 01:30:35.688279651 +-- +createUnixDateTimeNanos :: Year -> Month -> Day -> Hour -> Minute -> Second -> Nanos -> UnixDateTimeNanos +createUnixDateTimeNanos year month day hour minute second (Nanos nanos) = + check "createUnixDateTimeNanos" $ UnixDateTimeNanos base nano + where (micros, nano) = fmap fromIntegral $ divMod nanos 1000 + Second seconds = epochToTime year month day hour minute second + base = seconds * 1000000 + micros + +-- | Create a Unix date and time with picosecond granularity. +-- +-- > >>> createUnixDateTimePicos 2014 August 02 10 57 54 809479393286 +-- > 2014-08-02 10:57:54.809479393286 +-- +createUnixDateTimePicos :: Year -> Month -> Day -> Hour -> Minute -> Second -> Picos -> UnixDateTimePicos +createUnixDateTimePicos year month day hour minute second (Picos picos) = + check "createUnixDateTimePicos" $ UnixDateTimePicos base pico + where (micros, pico) = fmap fromIntegral $ divMod picos 1000000 + Second seconds = epochToTime year month day hour minute second + base = seconds * 1000000 + micros + +-- | Decompose 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 (December, days - 334) + else if days >= 305 + then (November, days - 304) + else (October , days - 273) + else if days >= 244 + then (September, days - 243) + else if days >= 213 + then (August, days - 212) + else (July , days - 181) + else if days >= 091 + then if days >= 152 + then (June, days - 151) + else if days >= 121 + then (May , days - 120) + else (April, days - 090) + else if days >= 060 + then (March, days - 059) + else if days >= 031 + then (February, days - 030) + else (January , days + 001) + else if days >= 181 + then if days >= 273 + then if days >= 334 + then (December, days - 333) + else if days >= 304 + then (November, days - 303) + else (October , days - 272) + else if days >= 243 + then (September, days - 242) + else if days >= 212 + then (August, days - 211) + else (July , days - 180) + else if days >= 090 + then if days >= 151 + then (June, days - 150) + else if days >= 120 + then (May , days - 119) + else (April, days - 089) + else if days >= 059 + then (March, days - 058) + else if days >= 031 + then (February, days - 030) + else (January , days + 001) + +-- | Decompose a Unix date into a human-readable format. +decompUnixDate :: UnixDate -> DateStruct +decompUnixDate (UnixDate base) = + go 1970 $ Day base + 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 = toEnum $ (fromIntegral base + 4) `mod` 7 + leap = isLeapYear year + size = if leap then 366 else 365 + (month, mday) = decompYearToDate days leap + +-- | Decompose a Unix date and time into a human-readable format. +decompUnixDateTime :: UnixDateTime -> DateTimeStruct +decompUnixDateTime (UnixDateTime base) = + DateTimeStruct _d_year _d_mon _d_mday _d_wday hour mn sec + where DateStruct{..} = decompUnixDate $ UnixDate date + (date, mod1) = both fromIntegral Hour $ divMod base 86400 + (hour, mod2) = fmap fromIntegral $ divMod mod1 03600 + (mn , sec ) = fmap realToFrac $ divMod mod2 00060 + +-- | Decompose a Unix date and time with millisecond granularity into a human-readable format. +decompUnixDateTimeMillis :: UnixDateTimeMillis -> DateTimeStruct +decompUnixDateTimeMillis (UnixDateTimeMillis base) = + DateTimeStruct _d_year _d_mon _d_mday _d_wday hour mn $ sec + mill / 0001000 + where DateStruct{..} = decompUnixDate $ UnixDate date + (date, mod1) = both fromIntegral Hour $ divMod base 86400000 + (hour, mod2) = fmap fromIntegral $ divMod mod1 03600000 + (mn , mod3) = divMod mod2 00060000 + (sec , mill) = both realToFrac realToFrac $ divMod mod3 00001000 + +-- | Decompose a Unix date and time with microsecond granularity into a human-readable format. +decompUnixDateTimeMicros :: UnixDateTimeMicros -> DateTimeStruct +decompUnixDateTimeMicros (UnixDateTimeMicros base) = + DateTimeStruct _d_year _d_mon _d_mday _d_wday hour mn $ sec + micr / 1000000 + where DateStruct{..} = decompUnixDate $ UnixDate date + (date, mod1) = both fromIntegral Hour $ divMod base 86400000000 + (hour, mod2) = fmap fromIntegral $ divMod mod1 03600000000 + (mn , mod3) = divMod mod2 00060000000 + (sec , micr) = both realToFrac realToFrac $ divMod mod3 00001000000 + +-- | Decompose a Unix date and time with nanosecond granularity into a human-readable format. +decompUnixDateTimeNanos :: UnixDateTimeNanos -> DateTimeStruct +decompUnixDateTimeNanos (UnixDateTimeNanos base nano) = + modify dt_sec (+ fromIntegral nano / 0001000000000) . decompUnixDateTimeMicros $ UnixDateTimeMicros base + +-- | Decompose a Unix date and time with picosecond granularity into a human-readable format. +decompUnixDateTimePicos :: UnixDateTimePicos -> DateTimeStruct +decompUnixDateTimePicos (UnixDateTimePicos base pico) = + modify dt_sec (+ fromIntegral pico / 1000000000000) . decompUnixDateTimeMicros $ UnixDateTimeMicros base + +instance Convertible UnixDateTime UnixDate where + safeConvert = Right . UnixDate . fromIntegral . flip div 00000086400 . _uni_sec_base + +instance Convertible UnixDateTimeMillis UnixDate where + safeConvert = Right . UnixDate . fromIntegral . flip div 00086400000 . _uni_mil_base + +instance Convertible UnixDateTimeMicros UnixDate where + safeConvert = Right . UnixDate . fromIntegral . flip div 86400000000 . _uni_mic_base + +instance Convertible UnixDateTimeNanos UnixDate where + safeConvert = Right . UnixDate . fromIntegral . flip div 86400000000 . _uni_nan_base + +instance Convertible UnixDateTimePicos UnixDate where + safeConvert = Right . UnixDate . fromIntegral . flip div 86400000000 . _uni_pic_base + +instance Date UnixDate where + toDateStruct = decompUnixDate + fromDateStruct DateStruct{..} = + createUnixDate _d_year _d_mon _d_mday + +instance Date UnixDateTime where + toDateStruct = decompUnixDate . convert + fromDateStruct DateStruct{..} = + createUnixDateTime _d_year _d_mon _d_mday 0 0 0 + +instance Date UnixDateTimeMillis where + toDateStruct = decompUnixDate . convert + fromDateStruct DateStruct{..} = + createUnixDateTimeMillis _d_year _d_mon _d_mday 0 0 0 0 + +instance Date UnixDateTimeMicros where + toDateStruct = decompUnixDate . convert + fromDateStruct DateStruct{..} = + createUnixDateTimeMicros _d_year _d_mon _d_mday 0 0 0 0 + +instance Date UnixDateTimeNanos where + toDateStruct = decompUnixDate . convert + fromDateStruct DateStruct{..} = + createUnixDateTimeNanos _d_year _d_mon _d_mday 0 0 0 0 + +instance Date UnixDateTimePicos where + toDateStruct = decompUnixDate . convert + fromDateStruct DateStruct{..} = + createUnixDateTimePicos _d_year _d_mon _d_mday 0 0 0 0 + +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 Show UnixDate where + show date = printf "%04d-%02d-%02d" _d_year mon _d_mday + where DateStruct{..} = toDateStruct date + mon = fromEnum _d_mon + 1 + +instance Show UnixDateTime where + show time = printf "%04d-%02d-%02d %02d:%02d:%02d" _dt_year mon _dt_mday _dt_hour _dt_min sec + where DateTimeStruct{..} = toDateTimeStruct time + mon = fromEnum _dt_mon + 1 + sec = round _dt_sec :: Second + +instance Show UnixDateTimeMillis where + show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%03d" _dt_year mon _dt_mday _dt_hour _dt_min sec mill + where DateTimeStruct{..} = toDateTimeStruct time + mon = fromEnum _dt_mon + 1 + (sec, mill) = properFracMillis _dt_sec + +instance Show UnixDateTimeMicros where + show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%06d" _dt_year mon _dt_mday _dt_hour _dt_min sec micr + where DateTimeStruct{..} = toDateTimeStruct time + mon = fromEnum _dt_mon + 1 + (sec, micr) = properFracMicros _dt_sec + +instance Show UnixDateTimeNanos where + show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%09d" _dt_year mon _dt_mday _dt_hour _dt_min sec nano + where DateTimeStruct{..} = toDateTimeStruct time + mon = fromEnum _dt_mon + 1 + (sec, nano) = properFracNanos _dt_sec + +instance Show UnixDateTimePicos where + show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%012d" _dt_year mon _dt_mday _dt_hour _dt_min sec pico + where DateTimeStruct{..} = toDateTimeStruct time + mon = fromEnum _dt_mon + 1 + (sec, pico) = properFracPicos _dt_sec + +-- | Get the current Unix date from the system clock. +-- +-- > >>> getCurrentUnixDate +-- > 2013-11-03 +-- +getCurrentUnixDate :: IO UnixDate +getCurrentUnixDate = getCurrentUnixDateTime >>= return . convert + +-- | Get the current Unix date and time from the system clock. +-- +-- > >>> getCurrentUnixDateTime +-- > 2013-11-03 23:09:38 +-- +getCurrentUnixDateTime :: IO UnixDateTime +getCurrentUnixDateTime = + with (C'timeval 0 0) $ \ ptr -> + c'gettimeofday ptr nullPtr >>= getResult ptr + where getResult ptr 0 = peek $ castPtr ptr + getResult _ _ = error "getCurrentUnixDateTime: unknown" + +-- | Get the current Unix date and time with millisecond granularity from the system clock. +-- +-- > >>> getCurrentUnixDateTimeMillis +-- > 2013-11-03 23:09:51.986 +-- +getCurrentUnixDateTimeMillis :: IO UnixDateTimeMillis +getCurrentUnixDateTimeMillis = + with (C'timeval 0 0) $ \ ptr -> + c'gettimeofday ptr nullPtr >>= getResult ptr + where getResult ptr 0 = peek ptr >>= \ (C'timeval (CLong base) (CLong micr)) -> + return $! UnixDateTimeMillis $ base * 1000 + micr `div` 1000 + getResult _ _ = error "getCurrentUnixDateTimeMillis: unknown" + +-- | Get the current Unix date and time with microsecond granularity from the system clock. +-- +-- > >>> getCurrentUnixDateTimeMicros +-- > 2013-11-03 23:10:06.498559 +-- +getCurrentUnixDateTimeMicros :: IO UnixDateTimeMicros +getCurrentUnixDateTimeMicros = + with (C'timeval 0 0) $ \ ptr -> + c'gettimeofday ptr nullPtr >>= getResult ptr + where getResult ptr 0 = peek ptr >>= \ (C'timeval (CLong base) (CLong micr)) -> + return $! UnixDateTimeMicros $ base * 1000000 + micr + getResult _ _ = error "getCurrentUnixDateTimeMicros: unknown" + +-- | Get the current Unix date and time with nanosecond granularity from the system clock. +-- +-- > >>> getCurrentUnixDateTimeNanos +-- > 2013-11-03 23:10:23.697893000 +-- +-- Note that this functions calls @gettimeofday@ behind the scenes. Therefore, the resultant +-- timestamp will have nanosecond granularity, but only microsecond resolution. +getCurrentUnixDateTimeNanos :: IO UnixDateTimeNanos +getCurrentUnixDateTimeNanos = + with (C'timeval 0 0) $ \ ptr -> + c'gettimeofday ptr nullPtr >>= getResult ptr + where getResult ptr 0 = peek ptr >>= \ (C'timeval (CLong base) (CLong micr)) -> + return $! UnixDateTimeNanos (base * 1000000 + micr) 0 + getResult _ _ = error "getCurrentUnixDateTimeNanos: unknown" + +-- | Get the current Unix date and time with picosecond granularity from the system clock. +-- +-- > >>> getCurrentUnixDateTimePicos +-- > 2013-11-03 23:10:44.633032000000 +-- +-- Note that this functions calls @gettimeofday@ behind the scenes. Therefore, the resultant +-- timestamp will have picosecond granularity, but only microsecond resolution. +getCurrentUnixDateTimePicos :: IO UnixDateTimePicos +getCurrentUnixDateTimePicos = + with (C'timeval 0 0) $ \ ptr -> + c'gettimeofday ptr nullPtr >>= getResult ptr + where getResult ptr 0 = peek ptr >>= \ (C'timeval (CLong base) (CLong micr)) -> + return $! UnixDateTimePicos (base * 1000000 + micr) 0 + getResult _ _ = error "getCurrentUnixDateTimePicos: unknown" + +-- | Convert a Unix date and time with nanosecond granularity into an integer. +fromNano :: UnixDateTimeNanos -> Integer +fromNano (UnixDateTimeNanos base nano) = toInteger base * 0001000 + toInteger nano + +-- | Convert a Unix date and time with picosecond granularity into an integer. +fromPico :: UnixDateTimePicos -> Integer +fromPico (UnixDateTimePicos base pico) = toInteger base * 1000000 + toInteger pico + +-- | Convert an integer into a Unix date and time with nanosecond granularity. +toNano :: Integer -> UnixDateTimeNanos +toNano = uncurry UnixDateTimeNanos . both fromInteger fromInteger . flip divMod 1000 + +-- | Convert an integer into a Unix date and time with picosecond granularity. +toPico :: Integer -> UnixDateTimePicos +toPico = uncurry UnixDateTimePicos . both fromInteger fromInteger . flip divMod 1000000 + +instance Duration UnixDate Day where + duration (UnixDate old) (UnixDate new) = Day (new - old) + +instance Duration UnixDateTime Second where + duration (UnixDateTime old) (UnixDateTime new) = Second (new - old) + +instance Duration UnixDateTimeMillis Second where + duration (UnixDateTimeMillis old ) (UnixDateTimeMillis new ) = Second (new - old) `div` 1000 + +instance Duration UnixDateTimeMicros Second where + duration (UnixDateTimeMicros old ) (UnixDateTimeMicros new ) = Second (new - old) `div` 1000000 + +instance Duration UnixDateTimeNanos Second where + duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = Second (new - old) `div` 1000000 + +instance Duration UnixDateTimePicos Second where + duration (UnixDateTimePicos old _) (UnixDateTimePicos new _) = Second (new - old) `div` 1000000 + +instance Duration UnixDateTimeMillis Millis where + duration (UnixDateTimeMillis old ) (UnixDateTimeMillis new ) = Millis (new - old) + +instance Duration UnixDateTimeMicros Millis where + duration (UnixDateTimeMicros old ) (UnixDateTimeMicros new ) = Millis (new - old) `div` 1000 + +instance Duration UnixDateTimeNanos Millis where + duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = Millis (new - old) `div` 1000 + +instance Duration UnixDateTimePicos Millis where + duration (UnixDateTimePicos old _) (UnixDateTimePicos new _) = Millis (new - old) `div` 1000 + +instance Duration UnixDateTimeMicros Micros where + duration (UnixDateTimeMicros old ) (UnixDateTimeMicros new ) = Micros (new - old) + +instance Duration UnixDateTimeNanos Micros where + duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = Micros (new - old) + +instance Duration UnixDateTimePicos Micros where + duration (UnixDateTimePicos old _) (UnixDateTimePicos new _) = Micros (new - old) + +instance Duration UnixDateTimeNanos Nanos where + duration old new = + if res < toInteger (maxBound::Int64) then Nanos $ fromInteger res + else error "duration{UnixDateTimeNanos,Nanos}: integer overflow" + where res = fromNano new - fromNano old + +instance Duration UnixDateTimePicos Nanos where + duration old new = + if res < toInteger (maxBound::Int64) then Nanos $ fromInteger res `div` 1000 + else error "duration{UnixDateTimePicos,Nanos}: integer overflow" + where res = fromPico new - fromPico old + +instance Duration UnixDateTimePicos Picos where + duration old new = + if res < toInteger (maxBound::Int64) then Picos $ fromInteger res + else error "duration{UnixDateTimePicos,Picos}: integer overflow" + where res = fromPico new - fromPico old + +instance Random UnixDate where + random = first toEnum . randomR (0,000000000000000002932896) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + +instance Random UnixDateTime where + random = first toEnum . randomR (0,000000000000253402300799) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + +instance Random UnixDateTimeMillis where + random = first toEnum . randomR (0,000000000253402300799999) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + +instance Random UnixDateTimeMicros where + random = first toEnum . randomR (0,000000253402300799999999) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + +instance Random UnixDateTimeNanos where + random = first toNano . randomR (0,000253402300799999999999) + randomR (a,b) = first toNano . randomR (fromNano a, fromNano b) + +instance Random UnixDateTimePicos where + random = first toPico . randomR (0,253402300799999999999999) + randomR (a,b) = first toPico . randomR (fromPico a, fromPico b) + +-- | Show a Unix date as a pretty string. +-- +-- > >>> prettyUnixDate $ createUnixDate 2014 August 16 +-- > "Saturday, August 16th, 2014" +-- +prettyUnixDate :: (Unix d, Date d) => d -> String +prettyUnixDate date = + printf "%s, %s %s, %04d" wday mon mday _d_year + where DateStruct{..} = toDateStruct date + wday = show _d_wday + mon = show _d_mon + mday = show _d_mday ++ showSuffix _d_mday + +-- | Show a Unix date and time as a pretty string. +-- +-- > >>> getCurrentUnixDateTime >>= return . prettyUnixDateTime +-- > "6:44 AM, Tuesday, December 31st, 2013" +-- +prettyUnixDateTime :: (Unix dt, 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 = show _dt_mon + mday = show _dt_mday ++ showSuffix _dt_mday + ampm = showPeriod _dt_hour + hour | _dt_hour == 00 = 12 + | _dt_hour <= 12 = _dt_hour + | otherwise = _dt_hour - 12 + +-- | Perform a bounds check on the given Unix timestamp. +check :: forall a . Bounded a => Ord a => Unix a => String -> a -> a +check f x = + if minBound <= x && x <= maxBound then x + else error $ f ++ ": base (" ++ base ++ ") out of bounds (" ++ bounds ++ ")" + where base = show (unixBase x) + bounds = show (unixBase (minBound::a)) ++ "," ++ show (unixBase (maxBound::a)) + +-- | A convenient synonym. +both :: forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d) +both = (***) diff --git a/time-exts.cabal b/time-exts.cabal --- a/time-exts.cabal +++ b/time-exts.cabal @@ -1,5 +1,5 @@ Name: time-exts -Version: 1.1.0 +Version: 1.1.1 License: BSD3 License-File: LICENSE Copyright: Copyright (c) 2014, Enzo Haussecker. All rights reserved.