--------------------------------------------------------------- -- 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