diff --git a/._LICENSE b/._LICENSE new file mode 100644 Binary files /dev/null and b/._LICENSE differ diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2013, Enzo Haussecker. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +- Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/Data/Time/Exts.hs b/src/Data/Time/Exts.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Exts.hs @@ -0,0 +1,19 @@ +--------------------------------------------------------------- +-- Copyright (c) 2013, Enzo Haussecker. All rights reserved. -- +--------------------------------------------------------------- + +{-# OPTIONS -Wall #-} + +module Data.Time.Exts ( + module Data.Time.Exts.Base + , module Data.Time.Exts.C + , module Data.Time.Exts.Local + , module Data.Time.Exts.Unix + , module Data.Time.Exts.Zone + ) where + +import Data.Time.Exts.Base +import Data.Time.Exts.C +import Data.Time.Exts.Local +import Data.Time.Exts.Unix +import Data.Time.Exts.Zone diff --git a/src/Data/Time/Exts/Base.hs b/src/Data/Time/Exts/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Exts/Base.hs @@ -0,0 +1,281 @@ +--------------------------------------------------------------- +-- Copyright (c) 2013, Enzo Haussecker. All rights reserved. -- +--------------------------------------------------------------- + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS -Wall #-} +{-# OPTIONS -fno-warn-name-shadowing #-} + +module Data.Time.Exts.Base ( + + Date(..) + , Zone(..) + , DateZone(..) + , DateTime(..) + , DateTimeZone(..) + , DateTimeMath(..) + + , DateStruct(..) + , DateZoneStruct(..) + , DateTimeStruct(..) + , DateTimeZoneStruct(..) + + , Year(..) + , Month(..) + , Day(..) + , DayOfWeek(..) + , Hour(..) + , Minute(..) + , Second(..) + , Millis(..) + , Micros(..) + , Nanos(..) + , Picos(..) + + , Pretty(..) + , prettyMonth + , prettyDay + , prettyHour + + , properFracMillis + , properFracMicros + , properFracNanos + , properFracPicos + + , epochToDate + , epochToYear + , yearToMonth + , dateToTime + + , isLeapYear + + ) where + +import Control.Arrow (first) +import Data.Aeson (FromJSON, ToJSON) +import Data.Int (Int32, Int64) +import Data.Time.Exts.Zone (TimeZone) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Text.Printf (PrintfArg) +import System.Random (Random(..)) + +class Date d where + toDateStruct :: d -> DateStruct + fromDateStruct :: DateStruct -> d + +class Zone z where + toZone :: z -> TimeZone -> z + +class DateZone dz where + toDateZoneStruct :: dz -> DateZoneStruct + fromDateZoneStruct :: DateZoneStruct -> dz + +class DateTime dt where + toDateTimeStruct :: dt -> DateTimeStruct + fromDateTimeStruct :: DateTimeStruct -> dt + +class DateTimeZone dtz where + toDateTimeZoneStruct :: dtz -> DateTimeZoneStruct + fromDateTimeZoneStruct :: DateTimeZoneStruct -> dtz + +class DateTimeMath a b where + plus :: a -> b -> a + +class Pretty a where + pretty :: a -> String + +data DateStruct = DateStruct { + _d_year :: {-# UNPACK #-} !Year -- ^ year + , _d_mon :: {-# UNPACK #-} !Month -- ^ month + , _d_mday :: {-# UNPACK #-} !Day -- ^ day of month + , _d_wday :: !DayOfWeek -- ^ day of week + } deriving (Eq,Generic,Ord,Show,Typeable) + +data DateZoneStruct = DateZoneStruct { + _dz_year :: {-# UNPACK #-} !Year -- ^ year + , _dz_mon :: {-# UNPACK #-} !Month -- ^ month + , _dz_mday :: {-# UNPACK #-} !Day -- ^ day of month + , _dz_wday :: !DayOfWeek -- ^ day of week + , _dz_zone :: !TimeZone -- ^ time zone + } deriving (Eq,Generic,Ord,Show,Typeable) + +data DateTimeStruct = DateTimeStruct { + _dt_year :: {-# UNPACK #-} !Year -- ^ year + , _dt_mon :: {-# UNPACK #-} !Month -- ^ month + , _dt_mday :: {-# UNPACK #-} !Day -- ^ day of month + , _dt_wday :: !DayOfWeek -- ^ day of week + , _dt_hour :: {-# UNPACK #-} !Hour -- ^ hour + , _dt_min :: {-# UNPACK #-} !Minute -- ^ minute + , _dt_sec :: {-# UNPACK #-} !Double -- ^ second + } deriving (Eq,Generic,Ord,Show,Typeable) + +data DateTimeZoneStruct = DateTimeZoneStruct { + _dtz_year :: {-# UNPACK #-} !Year -- ^ year + , _dtz_mon :: {-# UNPACK #-} !Month -- ^ month + , _dtz_mday :: {-# UNPACK #-} !Day -- ^ day of month + , _dtz_wday :: !DayOfWeek -- ^ day of week + , _dtz_hour :: {-# UNPACK #-} !Hour -- ^ hour + , _dtz_min :: {-# UNPACK #-} !Minute -- ^ minute + , _dtz_sec :: {-# UNPACK #-} !Double -- ^ second + , _dtz_zone :: !TimeZone -- ^ time zone + } deriving (Eq,Generic,Ord,Show,Typeable) + +newtype Year = Year {getYear :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Month = Month {getMonth :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Day = Day {getDay :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Hour = Hour {getHour :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Minute = Minute {getMinute :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Second = Second {getSecond :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Millis = Millis {getMillis :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Micros = Micros {getMicros :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Nanos = Nanos {getNanos :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Picos = Picos {getPicos :: Int64} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) + +data DayOfWeek = + Sunday + | Monday + | Tuesday + | Wednesday + | Thursday + | Friday + | Saturday + deriving (Eq,Enum,Generic,Ord,Show,Typeable) + +instance FromJSON DateStruct +instance FromJSON DateZoneStruct +instance FromJSON DateTimeStruct +instance FromJSON DateTimeZoneStruct +instance FromJSON DayOfWeek + +instance Random DayOfWeek where + random = first toEnum . randomR (0, 6) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + +instance Show Year where show Year {getYear } = "Year " ++ parens getYear +instance Show Month where show Month {getMonth } = "Month " ++ parens getMonth +instance Show Day where show Day {getDay } = "Day " ++ parens getDay +instance Show Hour where show Hour {getHour } = "Hour " ++ parens getHour +instance Show Minute where show Minute {getMinute} = "Minute " ++ parens getMinute +instance Show Second where show Second {getSecond} = "Second " ++ parens getSecond +instance Show Millis where show Millis {getMillis} = "Millis " ++ parens getMillis +instance Show Micros where show Micros {getMicros} = "Micros " ++ parens getMicros +instance Show Nanos where show Nanos {getNanos } = "Nanos " ++ parens getNanos +instance Show Picos where show Picos {getPicos } = "Picos " ++ parens getPicos + +instance ToJSON DateStruct +instance ToJSON DateZoneStruct +instance ToJSON DateTimeStruct +instance ToJSON DateTimeZoneStruct +instance ToJSON DayOfWeek + +-- | Shows the given numeric value as a string. +parens :: Num a => Ord a => Show a => a -> String +parens x = if x < 0 then '(' : show x ++ ")" else show x + +-- | Shows the given month as a string. +prettyMonth :: Month -> String +prettyMonth = \ case + 01 -> "January" + 02 -> "February" + 03 -> "March" + 04 -> "April" + 05 -> "May" + 06 -> "June" + 07 -> "July" + 08 -> "August" + 09 -> "September" + 10 -> "October" + 11 -> "November" + 12 -> "December" + _ -> error "prettyMonth: unknown month" + +-- | Shows the given day of the month as a string. +prettyDay :: Day -> String +prettyDay Day{getDay} = + if getDay <= 0 || 32 <= getDay + then error "prettyDay: unknown day" + else case getDay `mod` 10 of + 1 | getDay /= 11 -> str ++ "st" + 2 | getDay /= 12 -> str ++ "nd" + 3 | getDay /= 13 -> str ++ "rd" + _ -> str ++ "th" + where str = show getDay + +-- | Returns the given hour in AM-PM format. +prettyHour :: Hour -> (Hour, String) +prettyHour hour = + if | hour < 00 -> error "prettyHour: unknown hour" + | hour == 00 -> (12, "AM") + | hour <= 11 -> (hour, "AM") + | hour == 12 -> (hour, "PM") + | hour <= 23 -> (hour - 12, "PM") + | otherwise -> error "prettyHour: unknown hour" + +-- | Decomposes a floating point number into second and millisecond components. +properFracMillis :: Floating a => RealFrac a => a -> (Second, Millis) +properFracMillis millis = if rem == 1000 then (sec + 1, 0) else result + where result@(sec, rem) = fmap (round . (*) 1000) $ properFraction millis + +-- | Decomposes a floating point number into second and microsecond components. +properFracMicros :: Floating a => RealFrac a => a -> (Second, Micros) +properFracMicros micros = if rem == 1000000 then (sec + 1, 0) else result + where result@(sec, rem) = fmap (round . (*) 1000000) $ properFraction micros + +-- | Decomposes a floating point number into second and nanosecond components. +properFracNanos :: Floating a => RealFrac a => a -> (Second, Nanos) +properFracNanos nanos = if rem == 1000000000 then (sec + 1, 0) else result + where result@(sec, rem) = fmap (round . (*) 1000000000) $ properFraction nanos + +-- | Decomposes a floating point number into second and picosecond components. +properFracPicos :: Floating a => RealFrac a => a -> (Second, Picos) +properFracPicos picos = if rem == 1000000000000 then (sec + 1, 0) else result + where result@(sec, rem) = fmap (round . (*) 1000000000000) $ properFraction picos + +-- | Calculates the number of days that have +-- elapsed between Unix epoch and the given date. +epochToDate :: Year -> Month -> Day -> Day +epochToDate year mon mday = + epochToYear year + yearToMonth mon leap + mday - 1 + where leap = isLeapYear year + +-- | Calculates the number of days that have +-- elapsed between Unix epoch and the given year. +epochToYear :: Year -> Day +epochToYear Year{getYear} = + Day ((getYear - 1970) * 365 + (getYear - 1969) `div` 004 - + (getYear - 1901) `div` 100 + (getYear - 1601) `div` 400) + +-- | Calculates the number of days that have +-- elapsed between January 1st and the given month. +yearToMonth :: Month -> Bool -> Day +yearToMonth mon leap = + if leap + then + case mon of + 01 -> 000; 02 -> 031; 03 -> 060; 04 -> 091 + 05 -> 121; 06 -> 152; 07 -> 182; 08 -> 213 + 09 -> 244; 10 -> 274; 11 -> 305; 12 -> 335 + __ -> error "yearToMonth: month not supported" + else + case mon of + 01 -> 000; 02 -> 031; 03 -> 059; 04 -> 090 + 05 -> 120; 06 -> 151; 07 -> 181; 08 -> 212 + 09 -> 243; 10 -> 273; 11 -> 304; 12 -> 334 + __ -> error "yearToMonth: month not supported" + +-- | Calculates the number of seconds that have +-- elapsed between midnight and the given time. +dateToTime :: Hour -> Minute -> Second -> Second +dateToTime Hour{getHour} Minute{getMinute} sec = + Second ((getHour * 3600) + (getMinute * 60)) + sec + +-- | Checks if the given year is a leap year. +isLeapYear :: Year -> Bool +isLeapYear year = year `mod` 400 == 0 || (not (year `mod` 100 == 0) && year `mod` 4 == 0) diff --git a/src/Data/Time/Exts/C.hsc b/src/Data/Time/Exts/C.hsc new file mode 100644 --- /dev/null +++ b/src/Data/Time/Exts/C.hsc @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013, Enzo Haussecker, Nathan Howell. All rights reserved. -- +------------------------------------------------------------------------------ + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS -Wall #-} + +module Data.Time.Exts.C where + +import Data.Convertible (Convertible(..)) +import Foreign.C.String (CString) +import Foreign.C.Types (CInt(..), CLong, CTime(..)) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Unsafe (unsafeLocalState) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (FunPtr, Ptr, nullPtr, plusPtr) +import Foreign.Storable (Storable(..)) + +#include +#include +#include + +#starttype struct tm +#field tm_sec , CInt +#field tm_min , CInt +#field tm_hour , CInt +#field tm_mday , CInt +#field tm_mon , CInt +#field tm_year , CInt +#field tm_wday , CInt +#field tm_yday , CInt +#field tm_isdst , CInt +#field tm_gmtoff , CLong +#field tm_zone , CString +#stoptype + +#starttype struct timespec +#field tv_sec , CLong +#field tv_nsec , CLong +#stoptype + +#starttype struct timeval +#field tv_sec , CLong +#field tv_usec , CLong +#stoptype + +#ccall timegm , Ptr -> IO CTime +#ccall gmtime_r , Ptr CTime -> Ptr -> IO (Ptr ) +#ccall gettimeofday , Ptr -> Ptr () -> IO CInt + +instance Convertible CTime C'tm where + safeConvert = Right . unsafeLocalState . flip with f + where f x = alloca $ \ ptr -> c'gmtime_r x ptr >>= peek + +instance Convertible C'tm CTime where + safeConvert = Right . unsafeLocalState . flip with c'timegm + +-- | Gets the current Unix date and time from the system clock. +getTimeOfDay :: IO C'timeval +getTimeOfDay = with (C'timeval 0 0) $ \ ptr -> c'gettimeofday ptr nullPtr >>= getResult ptr + where getResult ptr 0 = peek ptr + getResult _ err = error $ "Error in call to gettimeofday: " ++ show err diff --git a/src/Data/Time/Exts/Local.hs b/src/Data/Time/Exts/Local.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Exts/Local.hs @@ -0,0 +1,1008 @@ +--------------------------------------------------------------- +-- Copyright (c) 2013, Enzo Haussecker. All rights reserved. -- +--------------------------------------------------------------- + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS -Wall #-} +{-# OPTIONS -fno-warn-type-defaults #-} + +module Data.Time.Exts.Local ( + + Local + , LocalDate(..) + , LocalDateTime(..) + , LocalDateTimeMillis(..) + , LocalDateTimeMicros(..) + , LocalDateTimeNanos(..) + , LocalDateTimePicos(..) + + , createLocalDate + , createLocalDateTime + , createLocalDateTimeMillis + , createLocalDateTimeMicros + , createLocalDateTimeNanos + , createLocalDateTimePicos + + , getCurrentLocalDate + , getCurrentLocalDateTime + , getCurrentLocalDateTimeMillis + , getCurrentLocalDateTimeMicros + , getCurrentLocalDateTimeNanos + , getCurrentLocalDateTimePicos + + , getCurrentLocalDate' + , getCurrentLocalDateTime' + , getCurrentLocalDateTimeMillis' + , getCurrentLocalDateTimeMicros' + , getCurrentLocalDateTimeNanos' + , getCurrentLocalDateTimePicos' + + , TransitionTimes + , getTransitionTimes + + , baseUnixToUTC + , baseUTCToUnix + + ) where + +import Control.Arrow ((***)) +import Control.DeepSeq (NFData) +import Data.Aeson (FromJSON, ToJSON) +import Data.Convertible (Convertible(..), convert) +import Data.Function (on) +import Data.Int (Int16, Int32, Int64) +import Data.Label (get, mkLabels, modify, set) +import Data.List (groupBy, sortBy) +import Data.Maybe (listToMaybe) +import Data.Monoid ((<>)) +import Data.Ord (comparing) +import Data.Time (UTCTime(..)) +import qualified Data.Time.Calendar as Calendar (Day(..)) +import Data.Time.Exts.Base +import Data.Time.Exts.Unix +import Data.Time.Exts.Zone +import Data.Time.LocalTime.TimeZone.Olson +import Data.Typeable (Typeable) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (Storable(..)) +import GHC.Generics (Generic) +import System.Random (Random(..)) +import Text.Printf (printf) + +class Local x + +data LocalDate = LocalDate { + _loc_day_base :: {-# UNPACK #-} !Int32 -- ^ days since Unix epoch + , _loc_day_zone :: {-# UNPACK #-} !Int16 -- ^ enumerated time zone + } deriving (Eq,Generic,Typeable) + +data LocalDateTime = LocalDateTime { + _loc_sec_base :: {-# UNPACK #-} !Int64 -- ^ seconds since Unix epoch (including leap seconds) + , _loc_sec_zone :: {-# UNPACK #-} !Int16 -- ^ enumerated time zone + } deriving (Eq,Generic,Typeable) + +data LocalDateTimeMillis = LocalDateTimeMillis { + _loc_mil_base :: {-# UNPACK #-} !Int64 -- ^ seconds since Unix epoch (including leap seconds) + , _loc_mil_mill :: {-# UNPACK #-} !Int16 -- ^ milliseconds + , _loc_mil_zone :: {-# UNPACK #-} !Int16 -- ^ enumerated time zone + } deriving (Eq,Generic,Typeable) + +data LocalDateTimeMicros = LocalDateTimeMicros { + _loc_mic_base :: {-# UNPACK #-} !Int64 -- ^ seconds since Unix epoch (including leap seconds) + , _loc_mic_micr :: {-# UNPACK #-} !Int32 -- ^ microseconds + , _loc_mic_zone :: {-# UNPACK #-} !Int16 -- ^ enumerated time zone + } deriving (Eq,Generic,Typeable) + +data LocalDateTimeNanos = LocalDateTimeNanos { + _loc_nan_base :: {-# UNPACK #-} !Int64 -- ^ seconds since Unix epoch (including leap seconds) + , _loc_nan_nano :: {-# UNPACK #-} !Int32 -- ^ nanoseconds + , _loc_nan_zone :: {-# UNPACK #-} !Int16 -- ^ enumerated time zone + } deriving (Eq,Generic,Typeable) + +data LocalDateTimePicos = LocalDateTimePicos { + _loc_pic_base :: {-# UNPACK #-} !Int64 -- ^ seconds since Unix epoch (including leap seconds) + , _loc_pic_pico :: {-# UNPACK #-} !Int64 -- ^ picoseconds + , _loc_pic_zone :: {-# UNPACK #-} !Int16 -- ^ enumerated time zone + } deriving (Eq,Generic,Typeable) + +type TransitionTimes = [LocalDateTime] + +mkLabels [''LocalDate + ,''LocalDateTime + ,''LocalDateTimeMillis + ,''LocalDateTimeMicros + ,''LocalDateTimeNanos + ,''LocalDateTimePicos + ] + +instance Bounded LocalDate where + minBound = LocalDate 0000000 00 + maxBound = LocalDate 2932896 51 + +instance Bounded LocalDateTime where + minBound = LocalDateTime 000000043200 00 + maxBound = LocalDateTime 253402257624 51 + +instance Bounded LocalDateTimeMillis where + minBound = LocalDateTimeMillis 000000043200 000000000000 00 + maxBound = LocalDateTimeMillis 253402257624 000000000999 51 + +instance Bounded LocalDateTimeMicros where + minBound = LocalDateTimeMicros 000000043200 000000000000 00 + maxBound = LocalDateTimeMicros 253402257624 000000999999 51 + +instance Bounded LocalDateTimeNanos where + minBound = LocalDateTimeNanos 000000043200 000000000000 00 + maxBound = LocalDateTimeNanos 253402257624 000999999999 51 + +instance Bounded LocalDateTimePicos where + minBound = LocalDateTimePicos 000000043200 000000000000 00 + maxBound = LocalDateTimePicos 253402257624 999999999999 51 + +instance Convertible LocalDateTime LocalDate where + safeConvert = Right . \ LocalDateTime{..} -> + flip LocalDate _loc_sec_zone . fst $ decompUTCBase _loc_sec_base _loc_sec_zone + +instance Convertible LocalDate Calendar.Day where + safeConvert LocalDate{..} = Right days + where days = Calendar.ModifiedJulianDay $ toInteger base + 40587 + base = _loc_day_base + +instance Convertible LocalDateTime UTCTime where + safeConvert LocalDateTime{..} = Right $ UTCTime days pico + where days = Calendar.ModifiedJulianDay $ toInteger base + 40587 + pico = fromIntegral secs + (base, secs) = decompUTCBase _loc_sec_base _loc_sec_zone + +instance Convertible LocalDateTimeMillis UTCTime where + safeConvert LocalDateTimeMillis{..} = Right $ UTCTime days pico + where days = Calendar.ModifiedJulianDay $ toInteger base + 40587 + pico = fromIntegral secs + fromIntegral _loc_mil_mill / 1000 + (base, secs) = decompUTCBase _loc_mil_base _loc_mil_zone + +instance Convertible LocalDateTimeMicros UTCTime where + safeConvert LocalDateTimeMicros{..} = Right $ UTCTime days pico + where days = Calendar.ModifiedJulianDay $ toInteger base + 40587 + pico = fromIntegral secs + fromIntegral _loc_mic_micr / 1000000 + (base, secs) = decompUTCBase _loc_mic_base _loc_mic_zone + +instance Convertible LocalDateTimeNanos UTCTime where + safeConvert LocalDateTimeNanos{..} = Right $ UTCTime days pico + where days = Calendar.ModifiedJulianDay $ toInteger base + 40587 + pico = fromIntegral secs + fromIntegral _loc_nan_nano / 1000000000 + (base, secs) = decompUTCBase _loc_nan_base _loc_nan_zone + +instance Convertible LocalDateTimePicos UTCTime where + safeConvert LocalDateTimePicos{..} = Right $ UTCTime days pico + where days = Calendar.ModifiedJulianDay $ toInteger base + 40587 + pico = fromIntegral secs + fromIntegral _loc_pic_pico / 1000000000000 + (base, secs) = decompUTCBase _loc_pic_base _loc_pic_zone + +instance Convertible Calendar.Day LocalDate where + safeConvert Calendar.ModifiedJulianDay{..} = Right $ LocalDate base 0 + where base = fromInteger toModifiedJulianDay - 40587 + +instance Convertible UTCTime LocalDateTime where + safeConvert UTCTime{..} = Right $ LocalDateTime base 0 + where days = fromInteger (Calendar.toModifiedJulianDay utctDay) - 40587 + base = baseUnixToUTC $ days * 86400 + truncate utctDayTime + +instance Convertible UTCTime LocalDateTimeMillis where + safeConvert UTCTime{..} = Right $ LocalDateTimeMillis base mill 0 + where days = fromInteger (Calendar.toModifiedJulianDay utctDay) - 40587 + base = baseUnixToUTC $ days * 86400 + sec + mill = truncate $ frac * 1000 + (sec, frac) = properFraction utctDayTime + +instance Convertible UTCTime LocalDateTimeMicros where + safeConvert UTCTime{..} = Right $ LocalDateTimeMicros base micr 0 + where days = fromInteger (Calendar.toModifiedJulianDay utctDay) - 40587 + base = baseUnixToUTC $ days * 86400 + sec + micr = truncate $ frac * 1000000 + (sec, frac) = properFraction utctDayTime + +instance Convertible UTCTime LocalDateTimeNanos where + safeConvert UTCTime{..} = Right $ LocalDateTimeNanos base nano 0 + where days = fromInteger (Calendar.toModifiedJulianDay utctDay) - 40587 + base = baseUnixToUTC $ days * 86400 + sec + nano = truncate $ frac * 1000000000 + (sec, frac) = properFraction utctDayTime + +instance Convertible UTCTime LocalDateTimePicos where + safeConvert UTCTime{..} = Right $ LocalDateTimePicos base pico 0 + where days = fromInteger (Calendar.toModifiedJulianDay utctDay) - 40587 + base = baseUnixToUTC $ days * 86400 + sec + pico = truncate $ frac * 1000000000000 + (sec, frac) = properFraction utctDayTime + +instance DateZone LocalDate where + toDateZoneStruct = decompLocalDate + fromDateZoneStruct DateZoneStruct{..} = + createLocalDate _dz_year _dz_mon _dz_mday _dz_zone + +instance DateTimeZone LocalDateTime where + toDateTimeZoneStruct = decompLocalDateTime + fromDateTimeZoneStruct DateTimeZoneStruct{..} = + createLocalDateTime _dtz_year _dtz_mon _dtz_mday _dtz_hour _dtz_min sec _dtz_zone + where sec = round _dtz_sec :: Second + +instance DateTimeZone LocalDateTimeMillis where + toDateTimeZoneStruct = decompLocalDateTimeMillis + fromDateTimeZoneStruct DateTimeZoneStruct{..} = + createLocalDateTimeMillis _dtz_year _dtz_mon _dtz_mday _dtz_hour _dtz_min sec mil _dtz_zone + where (sec, mil) = properFracMillis _dtz_sec + +instance DateTimeZone LocalDateTimeMicros where + toDateTimeZoneStruct = decompLocalDateTimeMicros + fromDateTimeZoneStruct DateTimeZoneStruct{..} = + createLocalDateTimeMicros _dtz_year _dtz_mon _dtz_mday _dtz_hour _dtz_min sec mic _dtz_zone + where (sec, mic) = properFracMicros _dtz_sec + +instance DateTimeZone LocalDateTimeNanos where + toDateTimeZoneStruct = decompLocalDateTimeNanos + fromDateTimeZoneStruct DateTimeZoneStruct{..} = + createLocalDateTimeNanos _dtz_year _dtz_mon _dtz_mday _dtz_hour _dtz_min sec nan _dtz_zone + where (sec, nan) = properFracNanos _dtz_sec + +instance DateTimeZone LocalDateTimePicos where + toDateTimeZoneStruct = decompLocalDateTimePicos + fromDateTimeZoneStruct DateTimeZoneStruct{..} = + createLocalDateTimePicos _dtz_year _dtz_mon _dtz_mday _dtz_hour _dtz_min sec pic _dtz_zone + where (sec, pic) = properFracPicos _dtz_sec + +instance DateTimeMath LocalDate Day where + timestamp `plus` days = + if minBound <= date && date <= maxBound + then date else error "plus: out of range" + where date = modify loc_day_base (+ fromIntegral days) timestamp + +instance DateTimeMath LocalDateTime Second where + timestamp `plus` secs = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where time = modify loc_sec_base (+ fromIntegral secs) timestamp + +instance DateTimeMath LocalDateTimeMillis Second where + timestamp `plus` secs = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where time = modify loc_mil_base (+ fromIntegral secs) timestamp + +instance DateTimeMath LocalDateTimeMicros Second where + timestamp `plus` secs = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where time = modify loc_mic_base (+ fromIntegral secs) timestamp + +instance DateTimeMath LocalDateTimeNanos Second where + timestamp `plus` secs = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where time = modify loc_nan_base (+ fromIntegral secs) timestamp + +instance DateTimeMath LocalDateTimePicos Second where + timestamp `plus` secs = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where time = modify loc_pic_base (+ fromIntegral secs) timestamp + +instance DateTimeMath LocalDateTimeMillis Millis where + timestamp `plus` mils = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where msum = fromIntegral (get loc_mil_mill timestamp) + fromIntegral mils + base = modify loc_mil_base (+ msum `div` 1000) timestamp + time = set loc_mil_mill (fromIntegral $ msum `mod` 1000) base + +instance DateTimeMath LocalDateTimeMicros Millis where + timestamp `plus` mils = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where msum = fromIntegral (get loc_mic_micr timestamp) + fromIntegral mils * 1000 + base = modify loc_mic_base (+ msum `div` 1000000) timestamp + time = set loc_mic_micr (fromIntegral $ msum `mod` 1000000) base + +instance DateTimeMath LocalDateTimeNanos Millis where + timestamp `plus` mils = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where nsum = fromIntegral (get loc_nan_nano timestamp) + fromIntegral mils * 1000000 + base = modify loc_nan_base (+ nsum `div` 1000000000) timestamp + time = set loc_nan_nano (fromIntegral $ nsum `mod` 1000000000) base + +instance DateTimeMath LocalDateTimePicos Millis where + timestamp `plus` mils = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where psum = fromIntegral (get loc_pic_pico timestamp) + fromIntegral mils * 1000000000 + base = modify loc_pic_base (+ psum `div` 1000000000000) timestamp + time = set loc_pic_pico (fromIntegral $ psum `mod` 1000000000000) base + +instance DateTimeMath LocalDateTimeMicros Micros where + timestamp `plus` mics = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where msum = fromIntegral (get loc_mic_micr timestamp) + fromIntegral mics + base = modify loc_mic_base (+ msum `div` 1000000) timestamp + time = set loc_mic_micr (fromIntegral $ msum `mod` 1000000) base + +instance DateTimeMath LocalDateTimeNanos Micros where + timestamp `plus` mics = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where nsum = fromIntegral (get loc_nan_nano timestamp) + fromIntegral mics * 1000 + base = modify loc_nan_base (+ nsum `div` 1000000000) timestamp + time = set loc_nan_nano (fromIntegral $ nsum `mod` 1000000000) base + +instance DateTimeMath LocalDateTimePicos Micros where + timestamp `plus` mics = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where psum = fromIntegral (get loc_pic_pico timestamp) + fromIntegral mics * 1000000 + base = modify loc_pic_base (+ psum `div` 1000000000000) timestamp + time = set loc_pic_pico (fromIntegral $ psum `mod` 1000000000000) base + +instance DateTimeMath LocalDateTimeNanos Nanos where + timestamp `plus` nans = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where nsum = fromIntegral (get loc_nan_nano timestamp) + fromIntegral nans + base = modify loc_nan_base (+ nsum `div` 1000000000) timestamp + time = set loc_nan_nano (fromIntegral $ nsum `mod` 1000000000) base + +instance DateTimeMath LocalDateTimePicos Nanos where + timestamp `plus` nans = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where psum = fromIntegral (get loc_pic_pico timestamp) + fromIntegral nans * 1000 + base = modify loc_pic_base (+ psum `div` 1000000000000) timestamp + time = set loc_pic_pico (fromIntegral $ psum `mod` 1000000000000) base + +instance DateTimeMath LocalDateTimePicos Picos where + timestamp `plus` pics = + if minBound <= time && time <= maxBound + then time else error "plus: out of range" + where psum = fromIntegral (get loc_pic_pico timestamp) + fromIntegral pics + base = modify loc_pic_base (+ psum `div` 1000000000000) timestamp + time = set loc_pic_pico (fromIntegral $ psum `mod` 1000000000000) base + +instance FromJSON LocalDate +instance FromJSON LocalDateTime +instance FromJSON LocalDateTimeMillis +instance FromJSON LocalDateTimeMicros +instance FromJSON LocalDateTimeNanos +instance FromJSON LocalDateTimePicos + +instance Local LocalDate +instance Local LocalDateTime +instance Local LocalDateTimeMillis +instance Local LocalDateTimeMicros +instance Local LocalDateTimeNanos +instance Local LocalDateTimePicos + +instance NFData LocalDate +instance NFData LocalDateTime +instance NFData LocalDateTimeMillis +instance NFData LocalDateTimeMicros +instance NFData LocalDateTimeNanos +instance NFData LocalDateTimePicos + +instance Ord LocalDate where + compare = comparing _loc_day_base + +instance Ord LocalDateTime where + compare = comparing _loc_sec_base + +instance Ord LocalDateTimeMillis where + compare = comparing _loc_mil_base + <> comparing _loc_mil_mill + +instance Ord LocalDateTimeMicros where + compare = comparing _loc_mic_base + <> comparing _loc_mic_micr + +instance Ord LocalDateTimeNanos where + compare = comparing _loc_nan_base + <> comparing _loc_nan_nano + +instance Ord LocalDateTimePicos where + compare = comparing _loc_pic_base + <> comparing _loc_pic_pico + +instance Pretty LocalDate where pretty = prettyLocalDate +instance Pretty LocalDateTime where pretty = prettyLocalDateTime +instance Pretty LocalDateTimeMillis where pretty = prettyLocalDateTime +instance Pretty LocalDateTimeMicros where pretty = prettyLocalDateTime +instance Pretty LocalDateTimeNanos where pretty = prettyLocalDateTime +instance Pretty LocalDateTimePicos where pretty = prettyLocalDateTime + +instance Random LocalDate where + random g = + case randomR (0, 2932896) g of { (base, g' ) -> + case randomR (0, 0000051) g' of { (zone, g'') -> (LocalDate base zone, g'') } } + randomR (a, b) g = + case randomR (_loc_day_base a, _loc_day_base b) g of { (base, g' ) -> + case randomR (_loc_day_zone a, _loc_day_zone b) g' of { (zone, g'') -> (LocalDate base zone, g'') } } + +instance Random LocalDateTime where + random g = + case randomR (43200, 253402257624) g of { (base, g' ) -> + case randomR (00000, 000000000051) g' of { (zone, g'') -> (LocalDateTime base zone, g'') } } + randomR (a, b) g = + case randomR (_loc_sec_base a, _loc_sec_base b) g of { (base, g' ) -> + case randomR (_loc_sec_zone a, _loc_sec_zone b) g' of { (zone, g'') -> (LocalDateTime base zone, g'') } } + +instance Random LocalDateTimeMillis where + random g = + case randomR (43200, 253402257624) g of { (base, g' ) -> + case randomR (43200, 000000000999) g' of { (mill, g'' ) -> + case randomR (00000, 000000000051) g'' of { (zone, g''') -> (LocalDateTimeMillis base mill zone, g''') } } } + randomR (a, b) g = + case randomR (minval, maxval) g of { (base_mill, g' ) -> + case randomR (000000, 000051) g' of { (zone , g'') -> + let (base, mill) = (***) fromInteger fromInteger $ divMod base_mill 1000 + in (LocalDateTimeMillis base mill zone, g'') } } + where minval = toInteger (_loc_mil_mill a) + toInteger (_loc_mil_base a) * 1000 + maxval = toInteger (_loc_mil_mill b) + toInteger (_loc_mil_base b) * 1000 + +instance Random LocalDateTimeMicros where + random g = + case randomR (43200, 253402257624) g of { (base, g' ) -> + case randomR (43200, 000000999999) g' of { (micr, g'' ) -> + case randomR (00000, 000000000051) g'' of { (zone, g''') -> (LocalDateTimeMicros base micr zone, g''') } } } + randomR (a, b) g = + case randomR (minval, maxval) g of { (base_micr, g' ) -> + case randomR (000000, 000051) g' of { (zone , g'') -> + let (base, micr) = (***) fromInteger fromInteger $ divMod base_micr 1000000 + in (LocalDateTimeMicros base micr zone, g'') } } + where minval = toInteger (_loc_mic_micr a) + toInteger (_loc_mic_base a) * 1000000 + maxval = toInteger (_loc_mic_micr b) + toInteger (_loc_mic_base b) * 1000000 + +instance Random LocalDateTimeNanos where + random g = + case randomR (43200, 253402257624) g of { (base, g' ) -> + case randomR (43200, 000999999999) g' of { (nano, g'' ) -> + case randomR (00000, 000000000051) g'' of { (zone, g''') -> (LocalDateTimeNanos base nano zone, g''') } } } + randomR (a, b) g = + case randomR (minval, maxval) g of { (base_nano, g' ) -> + case randomR (000000, 000051) g' of { (zone , g'') -> + let (base, nano) = (***) fromInteger fromInteger $ divMod base_nano 1000000000 + in (LocalDateTimeNanos base nano zone, g'') } } + where minval = toInteger (_loc_nan_nano a) + toInteger (_loc_nan_base a) * 1000000000 + maxval = toInteger (_loc_nan_nano b) + toInteger (_loc_nan_base b) * 1000000000 + +instance Random LocalDateTimePicos where + random g = + case randomR (43200, 253402257624) g of { (base, g' ) -> + case randomR (43200, 999999999999) g' of { (pico, g'' ) -> + case randomR (00000, 000000000051) g'' of { (zone, g''') -> (LocalDateTimePicos base pico zone, g''') } } } + randomR (a, b) g = + case randomR (minval, maxval) g of { (base_pico, g' ) -> + case randomR (000000, 000051) g' of { (zone , g'') -> + let (base, pico) = (***) fromInteger fromInteger $ divMod base_pico 1000000000000 + in (LocalDateTimePicos base pico zone, g'') } } + where minval = toInteger (_loc_pic_pico a) + toInteger (_loc_pic_base a) * 1000000000000 + maxval = toInteger (_loc_pic_pico b) + toInteger (_loc_pic_base b) * 1000000000000 + +instance Show LocalDate where + show date = printf str _dz_year _dz_mon _dz_mday abbr + where DateZoneStruct{..} = toDateZoneStruct date + str = "%04d-%02d-%02d %s" + abbr = show (convert _dz_zone :: TimeZoneAbbr) + +instance Show LocalDateTime where + show time = printf str _dtz_year _dtz_mon _dtz_mday _dtz_hour _dtz_min sec abbr + where DateTimeZoneStruct{..} = toDateTimeZoneStruct time + str = "%04d-%02d-%02d %02d:%02d:%02d %s" + abbr = show (convert _dtz_zone :: TimeZoneAbbr) + sec = round _dtz_sec :: Second + +instance Show LocalDateTimeMillis where + show time = printf str _dtz_year _dtz_mon _dtz_mday _dtz_hour _dtz_min sec mil abbr + where DateTimeZoneStruct{..} = toDateTimeZoneStruct time + str = "%04d-%02d-%02d %02d:%02d:%02d.%03d %s" + abbr = show (convert _dtz_zone :: TimeZoneAbbr) + (sec, mil) = properFracMillis _dtz_sec + +instance Show LocalDateTimeMicros where + show time = printf str _dtz_year _dtz_mon _dtz_mday _dtz_hour _dtz_min sec mic abbr + where DateTimeZoneStruct{..} = toDateTimeZoneStruct time + str = "%04d-%02d-%02d %02d:%02d:%02d.%06d %s" + abbr = show (convert _dtz_zone :: TimeZoneAbbr) + (sec , mic) = properFracMicros _dtz_sec + +instance Show LocalDateTimeNanos where + show time = printf str _dtz_year _dtz_mon _dtz_mday _dtz_hour _dtz_min sec nan abbr + where DateTimeZoneStruct{..} = toDateTimeZoneStruct time + str = "%04d-%02d-%02d %02d:%02d:%02d.%09d %s" + abbr = show (convert _dtz_zone :: TimeZoneAbbr) + (sec, nan) = properFracNanos _dtz_sec + +instance Show LocalDateTimePicos where + show time = printf str _dtz_year _dtz_mon _dtz_mday _dtz_hour _dtz_min sec pic abbr + where DateTimeZoneStruct{..} = toDateTimeZoneStruct time + str = "%04d-%02d-%02d %02d:%02d:%02d.%012d %s" + abbr = show (convert _dtz_zone :: TimeZoneAbbr) + (sec, pic) = properFracPicos _dtz_sec + +instance Storable LocalDate where + sizeOf _ = 06 + alignment = sizeOf + peekElemOff ptr n = do + let off = 06 * n + base <- peek . plusPtr ptr $ off + zone <- peek . plusPtr ptr $ off + 04 + return $! LocalDate base zone + pokeElemOff ptr n LocalDate{..} = do + let off = 06 * n + poke (plusPtr ptr $ off ) _loc_day_base + poke (plusPtr ptr $ off + 04) _loc_day_zone + +instance Storable LocalDateTime where + sizeOf _ = 10 + alignment = sizeOf + peekElemOff ptr n = do + let off = 10 * n + base <- peek . plusPtr ptr $ off + zone <- peek . plusPtr ptr $ off + 08 + return $! LocalDateTime base zone + pokeElemOff ptr n LocalDateTime{..} = do + let off = 10 * n + poke (plusPtr ptr $ off ) _loc_sec_base + poke (plusPtr ptr $ off + 08) _loc_sec_zone + +instance Storable LocalDateTimeMillis where + sizeOf _ = 12 + alignment = sizeOf + peekElemOff ptr n = do + let off = 12 * n + base <- peek . plusPtr ptr $ off + mill <- peek . plusPtr ptr $ off + 08 + zone <- peek . plusPtr ptr $ off + 10 + return $! LocalDateTimeMillis base mill zone + pokeElemOff ptr n LocalDateTimeMillis{..} = do + let off = 12 * n + poke (plusPtr ptr $ off ) _loc_mil_base + poke (plusPtr ptr $ off + 08) _loc_mil_mill + poke (plusPtr ptr $ off + 10) _loc_mil_zone + +instance Storable LocalDateTimeMicros where + sizeOf _ = 14 + alignment = sizeOf + peekElemOff ptr n = do + let off = 14 * n + base <- peek . plusPtr ptr $ off + micr <- peek . plusPtr ptr $ off + 08 + zone <- peek . plusPtr ptr $ off + 12 + return $! LocalDateTimeMicros base micr zone + pokeElemOff ptr n LocalDateTimeMicros{..} = do + let off = 14 * n + poke (plusPtr ptr $ off ) _loc_mic_base + poke (plusPtr ptr $ off + 08) _loc_mic_micr + poke (plusPtr ptr $ off + 12) _loc_mic_zone + +instance Storable LocalDateTimeNanos where + sizeOf _ = 14 + alignment = sizeOf + peekElemOff ptr n = do + let off = 14 * n + base <- peek . plusPtr ptr $ off + nano <- peek . plusPtr ptr $ off + 08 + zone <- peek . plusPtr ptr $ off + 12 + return $! LocalDateTimeNanos base nano zone + pokeElemOff ptr n LocalDateTimeNanos{..} = do + let off = 14 * n + poke (plusPtr ptr $ off ) _loc_nan_base + poke (plusPtr ptr $ off + 08) _loc_nan_nano + poke (plusPtr ptr $ off + 12) _loc_nan_zone + +instance Storable LocalDateTimePicos where + sizeOf _ = 18 + alignment = sizeOf + peekElemOff ptr n = do + let off = 18 * n + base <- peek . plusPtr ptr $ off + nano <- peek . plusPtr ptr $ off + 08 + zone <- peek . plusPtr ptr $ off + 16 + return $! LocalDateTimePicos base nano zone + pokeElemOff ptr n LocalDateTimePicos{..} = do + let off = 18 * n + poke (plusPtr ptr $ off ) _loc_pic_base + poke (plusPtr ptr $ off + 08) _loc_pic_pico + poke (plusPtr ptr $ off + 16) _loc_pic_zone + +instance ToJSON LocalDate +instance ToJSON LocalDateTime +instance ToJSON LocalDateTimeMillis +instance ToJSON LocalDateTimeMicros +instance ToJSON LocalDateTimeNanos +instance ToJSON LocalDateTimePicos + +instance Zone LocalDate where + toZone date = flip (set loc_day_zone) date . fromIntegral . fromEnum + +instance Zone LocalDateTime where + toZone time = flip (set loc_sec_zone) time . fromIntegral . fromEnum + +instance Zone LocalDateTimeMillis where + toZone time = flip (set loc_mil_zone) time . fromIntegral . fromEnum + +instance Zone LocalDateTimeMicros where + toZone time = flip (set loc_mic_zone) time . fromIntegral . fromEnum + +instance Zone LocalDateTimeNanos where + toZone time = flip (set loc_nan_zone) time . fromIntegral . fromEnum + +instance Zone LocalDateTimePicos where + toZone time = flip (set loc_pic_zone) time . fromIntegral . fromEnum + +-- | Creates a local date. +createLocalDate :: Year -> Month -> Day -> TimeZone -> LocalDate +createLocalDate year month day zone = + if minBound <= date && date <= maxBound then date + else error "createLocalDate: date not supported" + where date = LocalDate base . fromIntegral $ fromEnum zone + base = fromIntegral $ epochToDate year month day + +-- | Creates a local date and time. +createLocalDateTime :: Year -> Month -> Day -> Hour -> Minute -> Second -> TimeZone -> LocalDateTime +createLocalDateTime year month day hour minute second zone = + if minBound <= time && time <= maxBound then time + else error "createLocalDateTime: time not supported" + where time = LocalDateTime base . fromIntegral $ fromEnum zone + days = epochToDate year month day + base = baseUnixToUTC ((fromIntegral days * 86400) + + (fromIntegral hour * 03600) + + (fromIntegral minute * 00060) - + (offset zone * 00060)) + fromIntegral second + +-- | Creates a local date and time with millisecond granularity. +createLocalDateTimeMillis :: Year -> Month -> Day -> Hour -> Minute -> Second -> Millis -> TimeZone -> LocalDateTimeMillis +createLocalDateTimeMillis year month day hour minute second millis zone = + if minBound <= time && time <= maxBound then time + else error "createLocalDateTimeMillis: time not supported" + where time = LocalDateTimeMillis base mill . fromIntegral $ fromEnum zone + adds = fromIntegral $ millis `div` 1000 + mill = fromIntegral $ millis `mod` 1000 + days = epochToDate year month day + base = baseUnixToUTC ((fromIntegral days * 86400) + + (fromIntegral hour * 03600) + + (fromIntegral minute * 00060) - + (offset zone * 00060)) + fromIntegral second + adds + +-- | Creates a local date and time with microsecond granularity. +createLocalDateTimeMicros :: Year -> Month -> Day -> Hour -> Minute -> Second -> Micros -> TimeZone -> LocalDateTimeMicros +createLocalDateTimeMicros year month day hour minute second micros zone = + if minBound <= time && time <= maxBound then time + else error "createLocalDateTimeMicros: time not supported" + where time = LocalDateTimeMicros base micr . fromIntegral $ fromEnum zone + adds = fromIntegral $ micros `div` 1000000 + micr = fromIntegral $ micros `mod` 1000000 + days = epochToDate year month day + base = baseUnixToUTC ((fromIntegral days * 86400) + + (fromIntegral hour * 03600) + + (fromIntegral minute * 00060) - + (offset zone * 00060)) + fromIntegral second + adds + +-- | Creates a local date and time with nanosecond granularity. +createLocalDateTimeNanos :: Year -> Month -> Day -> Hour -> Minute -> Second -> Nanos -> TimeZone -> LocalDateTimeNanos +createLocalDateTimeNanos year month day hour minute second nanos zone = + if minBound <= time && time <= maxBound then time + else error "createLocalDateTimeNanos: time not supported" + where time = LocalDateTimeNanos base nano . fromIntegral $ fromEnum zone + adds = fromIntegral $ nanos `div` 1000000000 + nano = fromIntegral $ nanos `mod` 1000000000 + days = epochToDate year month day + base = baseUnixToUTC ((fromIntegral days * 86400) + + (fromIntegral hour * 03600) + + (fromIntegral minute * 00060) - + (offset zone * 00060)) + fromIntegral second + adds + +-- | Creates a local date and time with picosecond granularity. +createLocalDateTimePicos :: Year -> Month -> Day -> Hour -> Minute -> Second -> Picos -> TimeZone -> LocalDateTimePicos +createLocalDateTimePicos year month day hour minute second picos zone = + if minBound <= time && time <= maxBound then time + else error "createLocalDateTimePicos: time not supported" + where time = LocalDateTimePicos base pico . fromIntegral $ fromEnum zone + adds = fromIntegral $ picos `div` 1000000000000 + pico = fromIntegral $ picos `mod` 1000000000000 + days = epochToDate year month day + base = baseUnixToUTC ((fromIntegral days * 86400) + + (fromIntegral hour * 03600) + + (fromIntegral minute * 00060) - + (offset zone * 00060)) + fromIntegral second + adds + +-- | Decomposes a local date into a human-readable format. +decompLocalDate :: LocalDate -> DateZoneStruct +decompLocalDate LocalDate{..} = + DateZoneStruct _d_year _d_mon _d_mday _d_wday zone + where DateStruct{..} = toDateStruct date + date = UnixDate _loc_day_base + zone = toEnum $ fromIntegral _loc_day_zone + +-- | Decomposes a local date and time into a human-readable format. +decompLocalDateTime :: LocalDateTime -> DateTimeZoneStruct +decompLocalDateTime LocalDateTime{..} = + DateTimeZoneStruct _dt_year _dt_mon _dt_mday _dt_wday _dt_hour _dt_min sec zone + where DateTimeStruct{..} = toDateTimeStruct time + (,) base leap = baseUTCToUnix _loc_sec_base + zone = toEnum $ fromIntegral _loc_sec_zone + time = UnixDateTime base `plus` (offset zone :: Minute) + sec = _dt_sec + fromIntegral leap + +-- | Decomposes a local date and time with millisecond granularity into a human-readable format. +decompLocalDateTimeMillis :: LocalDateTimeMillis -> DateTimeZoneStruct +decompLocalDateTimeMillis LocalDateTimeMillis{..} = + DateTimeZoneStruct _dt_year _dt_mon _dt_mday _dt_wday _dt_hour _dt_min sec zone + where DateTimeStruct{..} = toDateTimeStruct time + (,) base leap = baseUTCToUnix _loc_mil_base + zone = toEnum $ fromIntegral _loc_mil_zone + time = UnixDateTime base `plus` (offset zone :: Minute) + sec = _dt_sec + fromIntegral leap + fromIntegral _loc_mil_mill / 1000 + +-- | Decomposes a local date and time with microsecond granularity into a human-readable format. +decompLocalDateTimeMicros :: LocalDateTimeMicros -> DateTimeZoneStruct +decompLocalDateTimeMicros LocalDateTimeMicros{..} = + DateTimeZoneStruct _dt_year _dt_mon _dt_mday _dt_wday _dt_hour _dt_min sec zone + where DateTimeStruct{..} = toDateTimeStruct time + (,) base leap = baseUTCToUnix _loc_mic_base + zone = toEnum $ fromIntegral _loc_mic_zone + time = UnixDateTime base `plus` (offset zone :: Minute) + sec = _dt_sec + fromIntegral leap + fromIntegral _loc_mic_micr / 1000000 + +-- | Decomposes a local date and time with nanosecond granularity into a human-readable format. +decompLocalDateTimeNanos :: LocalDateTimeNanos -> DateTimeZoneStruct +decompLocalDateTimeNanos LocalDateTimeNanos{..} = + DateTimeZoneStruct _dt_year _dt_mon _dt_mday _dt_wday _dt_hour _dt_min sec zone + where DateTimeStruct{..} = toDateTimeStruct time + (,) base leap = baseUTCToUnix _loc_nan_base + zone = toEnum $ fromIntegral _loc_nan_zone + time = UnixDateTime base `plus` (offset zone :: Minute) + sec = _dt_sec + fromIntegral leap + fromIntegral _loc_nan_nano / 1000000000 + +-- | Decomposes a local date and time with picosecond granularity into a human-readable format. +decompLocalDateTimePicos :: LocalDateTimePicos -> DateTimeZoneStruct +decompLocalDateTimePicos LocalDateTimePicos{..} = + DateTimeZoneStruct _dt_year _dt_mon _dt_mday _dt_wday _dt_hour _dt_min sec zone + where DateTimeStruct{..} = toDateTimeStruct time + (,) base leap = baseUTCToUnix _loc_pic_base + zone = toEnum $ fromIntegral _loc_pic_zone + time = UnixDateTime base `plus` (offset zone :: Minute) + sec = _dt_sec + fromIntegral leap + fromIntegral _loc_pic_pico / 1000000000000 + +-- | Decomposes a UTC base into day and second components. +decompUTCBase :: Int64 -> Int16 -> (Int32, Int32) +decompUTCBase locBase zone = (newBase, newSecs) + where zoneNum = toEnum $ fromIntegral zone + (,) nixBase leapSec = baseUTCToUnix locBase + offBase = nixBase + 60 * offset zoneNum + newBase = fromIntegral (offBase `div` 86400) + newSecs = fromIntegral (nixBase `mod` 86400) + fromIntegral leapSec + +-- | Gets the current local date from the system clock. +getCurrentLocalDate :: City -> IO LocalDate +getCurrentLocalDate city = getTransitionTimes city >>= getCurrentLocalDateTime' >>= return . convert + +-- | Gets the current local date from the system clock with preloaded transition times. +getCurrentLocalDate' :: TransitionTimes -> IO LocalDate +getCurrentLocalDate' ttimes = getCurrentLocalDateTime' ttimes >>= return . convert + +-- | Gets the current local date and time from the system clock. +getCurrentLocalDateTime :: City -> IO LocalDateTime +getCurrentLocalDateTime city = getTransitionTimes city >>= getCurrentLocalDateTime' + +-- | Gets the current local date and time from the system clock with preloaded transition times. +getCurrentLocalDateTime' :: TransitionTimes -> IO LocalDateTime +getCurrentLocalDateTime' ttimes = do + time@(UnixDateTime unix) <- getCurrentUnixDateTime + let base = baseUnixToUTC unix + f tt = _loc_sec_base tt > base + mval = listToMaybe $ dropWhile f ttimes + zone = maybe 17 _loc_sec_zone mval + if maybe True (/= convert time) nextLeap + then return $! LocalDateTime base zone + else let sec = round $ fromIntegral (unix `mod` 86400) / 86400 + in return $! LocalDateTime base zone `plus` Second sec + +-- | Gets the current local date and time with millisecond granularity from the system clock. +getCurrentLocalDateTimeMillis :: City -> IO LocalDateTimeMillis +getCurrentLocalDateTimeMillis city = getTransitionTimes city >>= getCurrentLocalDateTimeMillis' + +-- | Gets the current local date and time with millisecond granularity from the system clock with preloaded transition times. +getCurrentLocalDateTimeMillis' :: TransitionTimes -> IO LocalDateTimeMillis +getCurrentLocalDateTimeMillis' ttimes = do + time@UnixDateTimeMillis{..} <- getCurrentUnixDateTimeMillis + let base = baseUnixToUTC _uni_mil_base + f tt = _loc_sec_base tt > base + mval = listToMaybe $ dropWhile f ttimes + zone = maybe 17 _loc_sec_zone mval + if maybe True (/= convert time) nextLeap + then return $! LocalDateTimeMillis base _uni_mil_mill zone + else let millis = round $ fromIntegral (_uni_mil_base `mod` 86400) / 86.4 + in return $! LocalDateTimeMillis base _uni_mil_mill zone `plus` Millis millis + +-- | Gets the current local date and time with microsecond granularity from the system clock. +getCurrentLocalDateTimeMicros :: City -> IO LocalDateTimeMicros +getCurrentLocalDateTimeMicros city = getTransitionTimes city >>= getCurrentLocalDateTimeMicros' + +-- | Gets the current local date and time with microsecond granularity from the system clock with preloaded transition times. +getCurrentLocalDateTimeMicros' :: TransitionTimes -> IO LocalDateTimeMicros +getCurrentLocalDateTimeMicros' ttimes = do + time@UnixDateTimeMicros{..} <- getCurrentUnixDateTimeMicros + let base = baseUnixToUTC _uni_mic_base + f tt = _loc_sec_base tt > base + mval = listToMaybe $ dropWhile f ttimes + zone = maybe 17 _loc_sec_zone mval + if maybe True (/= convert time) nextLeap + then return $! LocalDateTimeMicros base _uni_mic_micr zone + else let micros = round $ fromIntegral (_uni_mic_base `mod` 86400) / 0.0864 + in return $! LocalDateTimeMicros base _uni_mic_micr zone `plus` Micros micros + +-- | Gets the current local date and time with nanosecond granularity from the system clock. +getCurrentLocalDateTimeNanos :: City -> IO LocalDateTimeNanos +getCurrentLocalDateTimeNanos city = getTransitionTimes city >>= getCurrentLocalDateTimeNanos' + +-- | Gets the current local date and time with nanosecond granularity from the system clock with preloaded transition times. +getCurrentLocalDateTimeNanos' :: TransitionTimes -> IO LocalDateTimeNanos +getCurrentLocalDateTimeNanos' ttimes = do + time@UnixDateTimeNanos{..} <- getCurrentUnixDateTimeNanos + let base = baseUnixToUTC _uni_nan_base + f tt = _loc_sec_base tt > base + mval = listToMaybe $ dropWhile f ttimes + zone = maybe 17 _loc_sec_zone mval + if maybe True (/= convert time) nextLeap + then return $! LocalDateTimeNanos base _uni_nan_nano zone + else let nanos = round $ fromIntegral (_uni_nan_base `mod` 86400) / 0.0000864 + in return $! LocalDateTimeNanos base _uni_nan_nano zone `plus` Nanos nanos + +-- | Gets the current local date and time with picosecond granularity from the system clock. +getCurrentLocalDateTimePicos :: City -> IO LocalDateTimePicos +getCurrentLocalDateTimePicos city = getTransitionTimes city >>= getCurrentLocalDateTimePicos' + +-- | Gets the current local date and time with picosecond granularity from the system clock with preloaded transition times. +getCurrentLocalDateTimePicos' :: TransitionTimes -> IO LocalDateTimePicos +getCurrentLocalDateTimePicos' ttimes = do + time@UnixDateTimePicos{..} <- getCurrentUnixDateTimePicos + let base = baseUnixToUTC _uni_pic_base + f tt = _loc_sec_base tt > base + mval = listToMaybe $ dropWhile f ttimes + zone = maybe 17 _loc_sec_zone mval + if maybe True (/= convert time) nextLeap + then return $! LocalDateTimePicos base _uni_pic_pico zone + else let picos = round $ fromIntegral (_uni_pic_base `mod` 86400) / 0.0000000864 + in return $! LocalDateTimePicos base _uni_pic_pico zone `plus` Picos picos + +-- | Shows a Local date as a string. +prettyLocalDate :: LocalDate -> String +prettyLocalDate date = + printf "%s, %s %s, %04d (%s)" wday mon mday _dz_year abbr + where DateZoneStruct{..} = toDateZoneStruct date + wday = show _dz_wday + mon = prettyMonth _dz_mon + mday = prettyDay _dz_mday + abbr = show (convert _dz_zone :: TimeZoneAbbr) + +-- | Shows a Local date and time as a string. +prettyLocalDateTime :: DateTimeZone dtz => dtz -> String +prettyLocalDateTime time = + printf str hour _dtz_min ampm wday mon mday _dtz_year abbr + where DateTimeZoneStruct{..} = toDateTimeZoneStruct time + str = "%d:%02d %s, %s, %s %s, %04d (%s)" + wday = show _dtz_wday + mon = prettyMonth _dtz_mon + mday = prettyDay _dtz_mday + abbr = show (convert _dtz_zone :: TimeZoneAbbr) + (hour, ampm) = prettyHour _dtz_hour + +-- | Returns a set of transition times for the given city. +getTransitionTimes :: City -> IO TransitionTimes +getTransitionTimes city = do + let file = getOlsonFile city + OlsonData{olsonTransitions, olsonTypes} <- getOlsonFromFile file + let ttimes = uniquetimes $ sortBy future2past olsonTransitions + return $! foldr (step olsonTypes) [] ttimes + where uniquetimes = groupBy $ on (==) transTime + future2past = comparing $ negate . transTime + step types ~[Transition{..}] accum = + if transTime < 0 + then [LocalDateTime 43200 zone] + else LocalDateTime base zone : accum + where TtInfo{..} = types !! transIndex + abbr = TimeZoneAbbr city tt_abbr + base = baseUnixToUTC $ fromIntegral transTime + zone = fromIntegral $ fromEnum (convert abbr :: TimeZone) + +-- | Converts a Unix base into a UTC base. +baseUnixToUTC :: Int64 -> Int64 +baseUnixToUTC base = + if | base >= 1341100800 -> base + 25 + | base >= 1230768000 -> base + 24 + | base >= 1136073600 -> base + 23 + | base >= 0915148800 -> base + 22 + | base >= 0867715200 -> base + 21 + | base >= 0820454400 -> base + 20 + | base >= 0773020800 -> base + 19 + | base >= 0741484800 -> base + 18 + | base >= 0709948800 -> base + 17 + | base >= 0662688000 -> base + 16 + | base >= 0631152000 -> base + 15 + | base >= 0567993600 -> base + 14 + | base >= 0489024000 -> base + 13 + | base >= 0425865600 -> base + 12 + | base >= 0394329600 -> base + 11 + | base >= 0362793600 -> base + 10 + | base >= 0315532800 -> base + 09 + | base >= 0283996800 -> base + 08 + | base >= 0252460800 -> base + 07 + | base >= 0220924800 -> base + 06 + | base >= 0189302400 -> base + 05 + | base >= 0157766400 -> base + 04 + | base >= 0126230400 -> base + 03 + | base >= 0094694400 -> base + 02 + | base >= 0078796800 -> base + 01 + | otherwise -> base + 00 + +-- | Converts a UTC base into a Unix base and leap second. +baseUTCToUnix :: Int64 -> (Int64, Second) +baseUTCToUnix base = + if | base >= 1341100825 -> (base - 0025, 0) + | base == 1341100824 -> (01341100799, 1) + | base >= 1230768024 -> (base - 0024, 0) + | base == 1230768023 -> (01230767999, 1) + | base >= 1136073623 -> (base - 0023, 0) + | base == 1136073622 -> (01136073599, 1) + | base >= 0915148822 -> (base - 0022, 0) + | base == 0915148821 -> (00915148799, 1) + | base >= 0867715221 -> (base - 0021, 0) + | base == 0867715220 -> (00867715199, 1) + | base >= 0820454420 -> (base - 0020, 0) + | base == 0820454419 -> (00820454399, 1) + | base >= 0773020819 -> (base - 0019, 0) + | base == 0773020818 -> (00773020799, 1) + | base >= 0741484818 -> (base - 0018, 0) + | base == 0741484817 -> (00741484799, 1) + | base >= 0709948817 -> (base - 0017, 0) + | base == 0709948816 -> (00709948799, 1) + | base >= 0662688016 -> (base - 0016, 0) + | base == 0662688015 -> (00662687999, 1) + | base >= 0631152015 -> (base - 0015, 0) + | base == 0631152014 -> (00631151999, 1) + | base >= 0567993614 -> (base - 0014, 0) + | base == 0567993613 -> (00567993599, 1) + | base >= 0489024013 -> (base - 0013, 0) + | base == 0489024012 -> (00489023999, 1) + | base >= 0425865612 -> (base - 0012, 0) + | base == 0425865611 -> (00425865599, 1) + | base >= 0394329611 -> (base - 0011, 0) + | base == 0394329610 -> (00394329599, 1) + | base >= 0362793610 -> (base - 0010, 0) + | base == 0362793609 -> (00362793599, 1) + | base >= 0315532809 -> (base - 0009, 0) + | base == 0315532808 -> (00315532799, 1) + | base >= 0283996808 -> (base - 0008, 0) + | base == 0283996807 -> (00283996799, 1) + | base >= 0252460807 -> (base - 0007, 0) + | base == 0252460806 -> (00252460799, 1) + | base >= 0220924806 -> (base - 0006, 0) + | base == 0220924805 -> (00220924799, 1) + | base >= 0189302405 -> (base - 0005, 0) + | base == 0189302404 -> (00189302399, 1) + | base >= 0157766404 -> (base - 0004, 0) + | base == 0157766403 -> (00157766399, 1) + | base >= 0126230403 -> (base - 0003, 0) + | base == 0126230402 -> (00126230399, 1) + | base >= 0094694402 -> (base - 0002, 0) + | base == 0094694401 -> (00094694399, 1) + | base >= 0078796801 -> (base - 0001, 0) + | base == 0078796800 -> (00078796799, 1) + | otherwise -> (base - 0000, 0) + +-- | The next leap second insertion date. +nextLeap :: Maybe UnixDate +nextLeap = Nothing diff --git a/src/Data/Time/Exts/Unix.hs b/src/Data/Time/Exts/Unix.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Exts/Unix.hs @@ -0,0 +1,822 @@ +--------------------------------------------------------------- +-- 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 diff --git a/src/Data/Time/Exts/Zone.hs b/src/Data/Time/Exts/Zone.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Exts/Zone.hs @@ -0,0 +1,449 @@ +--------------------------------------------------------------- +-- Copyright (c) 2013, Enzo Haussecker. All rights reserved. -- +--------------------------------------------------------------- + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wall #-} +{-# OPTIONS -fno-warn-type-defaults #-} + +module Data.Time.Exts.Zone where + +import Control.Arrow (first) +import Data.Aeson (FromJSON, ToJSON) +import Data.Convertible (Convertible(..)) +import Data.Ord (comparing) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import System.Random (Random(..)) + +data City = + Aden -- ^ Yemeni Republic + | Amman -- ^ Hashemite Kingdom of Jordan + | Anchorage -- ^ United States of America + | Auckland -- ^ New Zealand + | Baghdad -- ^ Republic of Iraq + | Berlin -- ^ Federal Republic of Germany + | Brussels -- ^ Kingdom of Belgium + | Bujumbura -- ^ Republic of Burundi + | Cairo -- ^ Arab Republic of Egypt + | Chicago -- ^ United States of America + | Damascus -- ^ Syrian Arab Republic + | Denver -- ^ United States of America + | Doha -- ^ State of Qatar + | Gaborone -- ^ Republic of Botswana + | Hong_Kong -- ^ People's Republic of China + | Honolulu -- ^ United States of America + | Johannesburg -- ^ Republic of South Africa + | Kabul -- ^ Islamic Republic of Afghanistan + | Karachi -- ^ Islamic Republic of Pakistan + | Kinshasa -- ^ Democratic Republic of the Congo + | Kolkata -- ^ Republic of India + | Kuwait_City -- ^ State of Kuwait + | London -- ^ United Kingdom of Great Britain and Northern Ireland + | Los_Angeles -- ^ United States of America + | Luanda -- ^ Republic of Angola + | Manama -- ^ Kingdom of Bahrain + | Minsk -- ^ Republic of Belarus + | Mogadishu -- ^ Federal Republic of Somalia + | Moscow -- ^ Russian Federation + | New_York -- ^ United States of America + | Oslo -- ^ Kingdom of Norway + | Ouagadougou -- ^ Burkina Faso + | Paris -- ^ French Republic + | Pyongyang -- ^ Democratic People's Republic of Korea + | Riyadh -- ^ Kingdom of Saudi Arabia + | Sao_Paulo -- ^ Federative Republic of Brazil + | Sarajevo -- ^ Bosnia and Herzegovina + | Seoul -- ^ Republic of Korea + | Shanghai -- ^ People's Republic of China + | Singapore -- ^ Republic of Singapore + | Sofia -- ^ Republic of Bulgaria + | Stockholm -- ^ Kingdom of Sweden + | Tehran -- ^ Islamic Republic of Iran + | Tel_Aviv -- ^ State of Israel + | Tirana -- ^ Republic of Albania + | Tokyo -- ^ Japan + | Toronto -- ^ Canada + | Universal -- ^ Tnternational Territory + | Vienna -- ^ Republic of Austria + | Zurich -- ^ Swiss Confederation + deriving (Eq,Enum,Generic,Ord,Show,Typeable) + +data TimeZone = + Afghanistan_Time + | Alaska_Daylight_Time + | Alaska_Hawaii_Daylight_Time + | Alaska_Hawaii_Standard_Time + | Alaska_Standard_Time + | Arabia_Daylight_Time + | Arabia_Standard_Time + | Brasilia_Summer_Time + | Brasilia_Time + | British_Summer_Time + | Central_Africa_Time + | Central_Daylight_Time + | Central_European_Summer_Time + | Central_European_Time + | Central_Standard_Time + | China_Daylight_Time + | China_Standard_Time + | Coordinated_Universal_Time + | East_Africa_Time + | Eastern_Daylight_Time + | Eastern_European_Summer_Time + | Eastern_European_Time + | Eastern_Standard_Time + | Further_Eastern_European_Time + | Greenwich_Mean_Time + | Gulf_Standard_Time + | Hawaii_Aleutian_Standard_Time + | Hong_Kong_Summer_Time + | Hong_Kong_Time + | India_Standard_Time + | Iran_Daylight_Time + | Iran_Standard_Time + | Israel_Daylight_Time + | Israel_Standard_Time + | Japan_Standard_Time + | Karachi_Time + | Korea_Daylight_Time + | Korea_Standard_Time + | Moscow_Daylight_Time + | Moscow_Standard_Time + | Mountain_Daylight_Time + | Mountain_Standard_Time + | New_Zealand_Daylight_Time + | New_Zealand_Standard_Time + | Pacific_Daylight_Time + | Pacific_Standard_Time + | Pakistan_Standard_Time + | Pakistan_Summer_Time + | Singapore_Time + | South_Africa_Standard_Time + | West_Africa_Time + | Yukon_Standard_Time + deriving (Eq,Enum,Generic,Show,Typeable) + +data TimeZoneAbbr = TimeZoneAbbr { + abbr_city :: City -- ^ Reference location + , abbr_str :: String -- ^ Time zone abbreviation string + } deriving (Eq,Generic,Typeable) + +instance Bounded City where + minBound = Aden + maxBound = Zurich + +instance Bounded TimeZone where + minBound = Afghanistan_Time + maxBound = Yukon_Standard_Time + +instance Convertible TimeZone TimeZoneAbbr where + safeConvert = Right . \ case + Afghanistan_Time -> TimeZoneAbbr Kabul "AFT" + Alaska_Daylight_Time -> TimeZoneAbbr Anchorage "AKDT" + Alaska_Hawaii_Daylight_Time -> TimeZoneAbbr Anchorage "AHDT" + Alaska_Hawaii_Standard_Time -> TimeZoneAbbr Anchorage "AHST" + Alaska_Standard_Time -> TimeZoneAbbr Anchorage "AKST" + Arabia_Daylight_Time -> TimeZoneAbbr Baghdad "ADT" + Arabia_Standard_Time -> TimeZoneAbbr Riyadh "AST" + Brasilia_Summer_Time -> TimeZoneAbbr Sao_Paulo "BRST" + Brasilia_Time -> TimeZoneAbbr Sao_Paulo "BRT" + British_Summer_Time -> TimeZoneAbbr London "BST" + Central_Africa_Time -> TimeZoneAbbr Gaborone "CAT" + Central_Daylight_Time -> TimeZoneAbbr Chicago "CDT" + Central_European_Summer_Time -> TimeZoneAbbr Paris "CEST" + Central_European_Time -> TimeZoneAbbr Paris "CET" + Central_Standard_Time -> TimeZoneAbbr Chicago "CST" + China_Daylight_Time -> TimeZoneAbbr Shanghai "CDT" + China_Standard_Time -> TimeZoneAbbr Shanghai "CST" + Coordinated_Universal_Time -> TimeZoneAbbr Universal "UTC" + East_Africa_Time -> TimeZoneAbbr Mogadishu "EAT" + Eastern_Daylight_Time -> TimeZoneAbbr New_York "EDT" + Eastern_European_Summer_Time -> TimeZoneAbbr Sofia "EEST" + Eastern_European_Time -> TimeZoneAbbr Sofia "EET" + Eastern_Standard_Time -> TimeZoneAbbr New_York "EST" + Further_Eastern_European_Time -> TimeZoneAbbr Minsk "FET" + Greenwich_Mean_Time -> TimeZoneAbbr London "GMT" + Gulf_Standard_Time -> TimeZoneAbbr Manama "GST" + Hawaii_Aleutian_Standard_Time -> TimeZoneAbbr Honolulu "HST" + Hong_Kong_Time -> TimeZoneAbbr Hong_Kong "HKT" + Hong_Kong_Summer_Time -> TimeZoneAbbr Hong_Kong "HKST" + India_Standard_Time -> TimeZoneAbbr Kolkata "IST" + Iran_Daylight_Time -> TimeZoneAbbr Tehran "IRDT" + Iran_Standard_Time -> TimeZoneAbbr Tehran "IRST" + Israel_Daylight_Time -> TimeZoneAbbr Tel_Aviv "IDT" + Israel_Standard_Time -> TimeZoneAbbr Tel_Aviv "IST" + Japan_Standard_Time -> TimeZoneAbbr Tokyo "JST" + Karachi_Time -> TimeZoneAbbr Karachi "KART" + Korea_Daylight_Time -> TimeZoneAbbr Seoul "KDT" + Korea_Standard_Time -> TimeZoneAbbr Seoul "KST" + Moscow_Daylight_Time -> TimeZoneAbbr Moscow "MSD" + Moscow_Standard_Time -> TimeZoneAbbr Moscow "MSK" + Mountain_Daylight_Time -> TimeZoneAbbr Denver "MDT" + Mountain_Standard_Time -> TimeZoneAbbr Denver "MST" + New_Zealand_Daylight_Time -> TimeZoneAbbr Auckland "NZDT" + New_Zealand_Standard_Time -> TimeZoneAbbr Auckland "NZST" + Pacific_Daylight_Time -> TimeZoneAbbr Los_Angeles "PDT" + Pacific_Standard_Time -> TimeZoneAbbr Los_Angeles "PST" + Pakistan_Standard_Time -> TimeZoneAbbr Karachi "PKT" + Pakistan_Summer_Time -> TimeZoneAbbr Karachi "PKST" + Singapore_Time -> TimeZoneAbbr Singapore "SGT" + South_Africa_Standard_Time -> TimeZoneAbbr Johannesburg "SAST" + West_Africa_Time -> TimeZoneAbbr Luanda "WAT" + Yukon_Standard_Time -> TimeZoneAbbr Anchorage "YST" + +instance Convertible TimeZoneAbbr TimeZone where + safeConvert = Right . \ TimeZoneAbbr{..} -> + case abbr_str of + "AFT" -> Afghanistan_Time + "AHDT" -> Alaska_Hawaii_Daylight_Time + "AHST" -> Alaska_Hawaii_Standard_Time + "AKDT" -> Alaska_Daylight_Time + "AKST" -> Alaska_Standard_Time + "ADT" -> Arabia_Daylight_Time + "AST" -> Arabia_Standard_Time + "BRST" -> Brasilia_Summer_Time + "BRT" -> Brasilia_Time + "BST" -> British_Summer_Time + "CAT" -> Central_Africa_Time + "CDT" -> case abbr_city of + Chicago -> Central_Daylight_Time + Shanghai -> China_Daylight_Time + _ -> missing abbr_city + "CEST" -> Central_European_Summer_Time + "CET" -> Central_European_Time + "CST" -> case abbr_city of + Chicago -> Central_Standard_Time + Shanghai -> China_Standard_Time + _ -> missing abbr_city + "EAT" -> East_Africa_Time + "EDT" -> Eastern_Daylight_Time + "EEST" -> Eastern_European_Summer_Time + "EET" -> Eastern_European_Time + "EST" -> Eastern_Standard_Time + "FET" -> Further_Eastern_European_Time + "GMT" -> Greenwich_Mean_Time + "GST" -> Gulf_Standard_Time + "HST" -> Hawaii_Aleutian_Standard_Time + "HKST" -> Hong_Kong_Summer_Time + "HKT" -> Hong_Kong_Time + "IDT" -> Israel_Daylight_Time + "IRDT" -> Iran_Daylight_Time + "IRST" -> Iran_Standard_Time + "IST" -> case abbr_city of + Kolkata -> India_Standard_Time + Tel_Aviv -> Israel_Standard_Time + _ -> missing abbr_city + "JST" -> Japan_Standard_Time + "KART" -> Karachi_Time + "KDT" -> Korea_Daylight_Time + "KST" -> Korea_Standard_Time + "MDT" -> Mountain_Daylight_Time + "MSD" -> Moscow_Daylight_Time + "MSK" -> Moscow_Standard_Time + "MST" -> Mountain_Standard_Time + "NZDT" -> New_Zealand_Daylight_Time + "NZST" -> New_Zealand_Standard_Time + "PDT" -> Pacific_Daylight_Time + "PKST" -> Pakistan_Summer_Time + "PKT" -> Pakistan_Standard_Time + "PST" -> Pacific_Standard_Time + "SAST" -> South_Africa_Standard_Time + "SGT" -> Singapore_Time + "UTC" -> Coordinated_Universal_Time + "WAT" -> West_Africa_Time + "YST" -> Yukon_Standard_Time + _ -> error $ "safeConvert: missing time zone abbreviation `" ++ abbr_str ++ "'" + where missing city = error $ "safeConvert: missing reference location `" ++ show city ++ "'" + +instance FromJSON City +instance FromJSON TimeZone +instance FromJSON TimeZoneAbbr + +instance Ord TimeZone where + compare = comparing offset + +instance Random City where + random = first toEnum . randomR (0, 49) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + +instance Random TimeZone where + random = first toEnum . randomR (0, 51) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + +instance Show TimeZoneAbbr where + show TimeZoneAbbr{abbr_str} = abbr_str + +instance ToJSON City +instance ToJSON TimeZone +instance ToJSON TimeZoneAbbr + +-- | A list of cities in alphabetical order. +cities :: [City] +cities = + [ Aden + , Amman + , Anchorage + , Auckland + , Baghdad + , Berlin + , Brussels + , Bujumbura + , Cairo + , Chicago + , Damascus + , Denver + , Doha + , Gaborone + , Hong_Kong + , Honolulu + , Johannesburg + , Kabul + , Karachi + , Kinshasa + , Kolkata + , Kuwait_City + , London + , Los_Angeles + , Luanda + , Manama + , Minsk + , Mogadishu + , Moscow + , New_York + , Oslo + , Ouagadougou + , Paris + , Pyongyang + , Riyadh + , Sao_Paulo + , Sarajevo + , Seoul + , Shanghai + , Singapore + , Sofia + , Stockholm + , Tehran + , Tel_Aviv + , Tirana + , Tokyo + , Toronto + , Universal + , Vienna + , Zurich + ] + +-- | Returns the Olson file associated with the given city. +getOlsonFile :: City -> FilePath +getOlsonFile = \ case + Aden -> "/usr/share/zoneinfo/Asia/Aden" + Amman -> "/usr/share/zoneinfo/Asia/Amman" + Anchorage -> "/usr/share/zoneinfo/America/Anchorage" + Auckland -> "/usr/share/zoneinfo/Pacific/Auckland" + Baghdad -> "/usr/share/zoneinfo/Asia/Baghdad" + Berlin -> "/usr/share/zoneinfo/Europe/Berlin" + Brussels -> "/usr/share/zoneinfo/Europe/Brussels" + Bujumbura -> "/usr/share/zoneinfo/Africa/Bujumbura" + Cairo -> "/usr/share/zoneinfo/Africa/Cairo" + Chicago -> "/usr/share/zoneinfo/America/Chicago" + Damascus -> "/usr/share/zoneinfo/Asia/Damascus" + Denver -> "/usr/share/zoneinfo/America/Denver" + Doha -> "/usr/share/zoneinfo/Asia/Qatar" + Gaborone -> "/usr/share/zoneinfo/Africa/Gaborone" + Hong_Kong -> "/usr/share/zoneinfo/Asia/Hong_Kong" + Honolulu -> "/usr/share/zoneinfo/Pacific/Honolulu" + Johannesburg -> "/usr/share/zoneinfo/Africa/Johannesburg" + Kabul -> "/usr/share/zoneinfo/Asia/Kabul" + Karachi -> "/usr/share/zoneinfo/Asia/Karachi" + Kinshasa -> "/usr/share/zoneinfo/Africa/Kinshasa" + Kuwait_City -> "/usr/share/zoneinfo/Asia/Kuwait" + Kolkata -> "/usr/share/zoneinfo/Asia/Kolkata" + London -> "/usr/share/zoneinfo/Europe/London" + Los_Angeles -> "/usr/share/zoneinfo/America/Los_Angeles" + Luanda -> "/usr/share/zoneinfo/Africa/Luanda" + Manama -> "/usr/share/zoneinfo/Asia/Bahrain" + Minsk -> "/usr/share/zoneinfo/Europe/Minsk" + Mogadishu -> "/usr/share/zoneinfo/Africa/Mogadishu" + Moscow -> "/usr/share/zoneinfo/Europe/Moscow" + New_York -> "/usr/share/zoneinfo/America/New_York" + Oslo -> "/usr/share/zoneinfo/Europe/Oslo" + Ouagadougou -> "/usr/share/zoneinfo/Africa/Ouagadougou" + Paris -> "/usr/share/zoneinfo/Europe/Paris" + Pyongyang -> "/usr/share/zoneinfo/Asia/Pyongyang" + Riyadh -> "/usr/share/zoneinfo/Asia/Riyadh" + Sao_Paulo -> "/usr/share/zoneinfo/America/Sao_Paulo" + Sarajevo -> "/usr/share/zoneinfo/Europe/Sarajevo" + Seoul -> "/usr/share/zoneinfo/Asia/Seoul" + Shanghai -> "/usr/share/zoneinfo/Asia/Shanghai" + Singapore -> "/usr/share/zoneinfo/Asia/Singapore" + Sofia -> "/usr/share/zoneinfo/Europe/Sofia" + Stockholm -> "/usr/share/zoneinfo/Europe/Stockholm" + Tehran -> "/usr/share/zoneinfo/Asia/Tehran" + Tel_Aviv -> "/usr/share/zoneinfo/Asia/Tel_Aviv" + Tirana -> "/usr/share/zoneinfo/Europe/Tirane" + Tokyo -> "/usr/share/zoneinfo/Asia/Tokyo" + Toronto -> "/usr/share/zoneinfo/America/Toronto" + Universal -> "/usr/share/zoneinfo/Universal" + Vienna -> "/usr/share/zoneinfo/Europe/Vienna" + Zurich -> "/usr/share/zoneinfo/Europe/Zurich" + +-- | Returns the offset (in minutes) for the given time zone. +offset :: Num a => TimeZone -> a +offset = \ case + Afghanistan_Time -> 270 + Alaska_Daylight_Time -> -480 + Alaska_Hawaii_Daylight_Time -> -540 + Alaska_Hawaii_Standard_Time -> -600 + Alaska_Standard_Time -> -540 + Arabia_Daylight_Time -> 240 + Arabia_Standard_Time -> 180 + Brasilia_Summer_Time -> -120 + Brasilia_Time -> -180 + British_Summer_Time -> 060 + Central_Africa_Time -> 120 + Central_Daylight_Time -> -300 + Central_European_Summer_Time -> 120 + Central_European_Time -> 060 + Central_Standard_Time -> -360 + China_Daylight_Time -> 540 + China_Standard_Time -> 480 + Coordinated_Universal_Time -> 000 + East_Africa_Time -> 180 + Eastern_Daylight_Time -> -240 + Eastern_European_Summer_Time -> 180 + Eastern_European_Time -> 120 + Eastern_Standard_Time -> -300 + Further_Eastern_European_Time -> 180 + Greenwich_Mean_Time -> 000 + Gulf_Standard_Time -> 240 + Hawaii_Aleutian_Standard_Time -> -600 + Hong_Kong_Summer_Time -> 540 + Hong_Kong_Time -> 480 + India_Standard_Time -> 330 + Iran_Daylight_Time -> 270 + Iran_Standard_Time -> 210 + Israel_Daylight_Time -> 180 + Israel_Standard_Time -> 120 + Japan_Standard_Time -> 540 + Karachi_Time -> 300 + Korea_Daylight_Time -> 600 + Korea_Standard_Time -> 540 + Moscow_Daylight_Time -> 240 + Moscow_Standard_Time -> 240 + Mountain_Daylight_Time -> -360 + Mountain_Standard_Time -> -420 + New_Zealand_Daylight_Time -> 780 + New_Zealand_Standard_Time -> 720 + Pacific_Daylight_Time -> -420 + Pacific_Standard_Time -> -480 + Pakistan_Standard_Time -> 300 + Pakistan_Summer_Time -> 360 + Singapore_Time -> 480 + South_Africa_Standard_Time -> 120 + West_Africa_Time -> 060 + Yukon_Standard_Time -> -540 diff --git a/time-exts.cabal b/time-exts.cabal new file mode 100644 --- /dev/null +++ b/time-exts.cabal @@ -0,0 +1,35 @@ +Name: time-exts +Version: 1.0.0 +License: BSD3 +License-File: LICENSE +Copyright: Copyright (c) 2013, Enzo Haussecker. All rights reserved. +Author: Enzo Haussecker +Maintainer: Enzo Haussecker +Stability: Stable +Category: Time +Synopsis: Efficient Timestamps +Homepage: https://github.com/enzoh/time-exts +Bug-Reports: https://github.com/enzoh/time-exts/issues +Build-Type: Simple +Cabal-Version: >= 1.16.0 +Description: Extensions to the Haskell time library, providing efficient Unix, UTC, and local timestamps. + +Library + Default-Language: Haskell2010 + HS-Source-Dirs: src + Exposed-Modules: Data.Time.Exts + Data.Time.Exts.Base + Data.Time.Exts.C + Data.Time.Exts.Local + Data.Time.Exts.Unix + Data.Time.Exts.Zone + Build-Depends: aeson, + base >= 4 && < 5, + convertible, + deepseq, + fclabels, + random, + time, + timezone-olson + Build-Tools: hsc2hs + GHC-Options: -rtsopts