diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013, Enzo Haussecker. All rights reserved. +Copyright (c) 2014, 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: diff --git a/src/Data/Time/Exts.hs b/src/Data/Time/Exts.hs --- a/src/Data/Time/Exts.hs +++ b/src/Data/Time/Exts.hs @@ -1,15 +1,27 @@ --------------------------------------------------------------- --- Copyright (c) 2013, Enzo Haussecker. All rights reserved. -- +-- Copyright (c) 2014, Enzo Haussecker. All rights reserved. -- --------------------------------------------------------------- {-# OPTIONS -Wall #-} +-- | Extensions to the Haskell time library. module Data.Time.Exts ( + + -- ** Basic Definitions module Data.Time.Exts.Base - , module Data.Time.Exts.C - , module Data.Time.Exts.Local + + -- ** Unix Timestamps , module Data.Time.Exts.Unix + + -- ** UTC and Local Timestamps + , module Data.Time.Exts.Local + + -- ** Locations and Time Zones , module Data.Time.Exts.Zone + + -- ** Language Bindings + , module Data.Time.Exts.C + ) where import Data.Time.Exts.Base diff --git a/src/Data/Time/Exts/Base.hs b/src/Data/Time/Exts/Base.hs --- a/src/Data/Time/Exts/Base.hs +++ b/src/Data/Time/Exts/Base.hs @@ -1,34 +1,33 @@ --------------------------------------------------------------- --- Copyright (c) 2013, Enzo Haussecker. All rights reserved. -- +-- Copyright (c) 2014, 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 #-} +-- | Basic definitions, including type classes, datatypes and functions. module Data.Time.Exts.Base ( - -- * Classes + -- ** Classes Date(..) - , Zone(..) - , DateZone(..) , DateTime(..) + , DateZone(..) , DateTimeZone(..) , DateTimeMath(..) + , Duration(..) + , Zone(..) - -- * Structs + -- ** Structs , DateStruct(..) - , DateZoneStruct(..) , DateTimeStruct(..) + , DateZoneStruct(..) , DateTimeZoneStruct(..) - -- * Components + -- ** Components , Year(..) , Month(..) , Day(..) @@ -41,26 +40,20 @@ , Nanos(..) , Picos(..) - -- * Pretty - , Pretty(..) - , prettyMonth - , prettyDay - , prettyHour - - -- * Fractions + -- ** Fractions , properFracMillis , properFracMicros , properFracNanos , properFracPicos - -- * Durations + -- ** Durations , epochToDate - , epochToYear - , yearToMonth - , dateToTime + , epochToTime - -- * Utilities + -- ** Utilities , isLeapYear + , showPeriod + , showSuffix ) where @@ -74,250 +67,259 @@ import System.Random (Random(..)) class Date d where - toDateStruct :: d -> DateStruct + + -- | Compose a timestamp from date components. fromDateStruct :: DateStruct -> d -class Zone z where - toZone :: z -> TimeZone -> z + -- | Decompose a timestamp into date components. + toDateStruct :: d -> DateStruct +class Date dt => DateTime dt where + + -- | Compose a timestamp from date and time components. + fromDateTimeStruct :: DateTimeStruct -> dt + + -- | Decompose a timestamp into date and time components. + toDateTimeStruct :: dt -> DateTimeStruct + class DateZone dz where - toDateZoneStruct :: dz -> DateZoneStruct + + -- | Compose a timestamp from date and time zone components. fromDateZoneStruct :: DateZoneStruct -> dz -class DateTime dt where - toDateTimeStruct :: dt -> DateTimeStruct - fromDateTimeStruct :: DateTimeStruct -> dt + -- | Decompose a timestamp into date and time zone components. + toDateZoneStruct :: dz -> DateZoneStruct -class DateTimeZone dtz where - toDateTimeZoneStruct :: dtz -> DateTimeZoneStruct +class DateZone dtz => DateTimeZone dtz where + + -- | Compose a timestamp from date, time and time zone components. fromDateTimeZoneStruct :: DateTimeZoneStruct -> dtz -class DateTimeMath a b where - plus :: a -> b -> a + -- | Decompose a timestamp into date, time and time zone components. + toDateTimeZoneStruct :: dtz -> DateTimeZoneStruct --- | Show a timestamp in a more human-readable format than the default 'Show' instance. -class Pretty a where - pretty :: a -> String +class Duration x c where + -- | Compute the date or time component duration between two timestamps. + duration :: x -> x -> c + +class DateTimeMath x c where + + -- | Add a timestamp with a date or time component. + plus :: x -> c -> x + +class Zone x where + + -- | Change the time zone of a timestamp. + rezone :: x -> TimeZone -> x + -- | A struct with date components. 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) - --- | A struct with date and zone components. -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 + _d_year :: {-# UNPACK #-} !Year + , _d_mon :: !Month + , _d_mday :: {-# UNPACK #-} !Day + , _d_wday :: !DayOfWeek } deriving (Eq,Generic,Ord,Show,Typeable) -- | A struct with date and time components. 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 + _dt_year :: {-# UNPACK #-} !Year + , _dt_mon :: !Month + , _dt_mday :: {-# UNPACK #-} !Day + , _dt_wday :: !DayOfWeek + , _dt_hour :: {-# UNPACK #-} !Hour + , _dt_min :: {-# UNPACK #-} !Minute + , _dt_sec :: {-# UNPACK #-} !Double } deriving (Eq,Generic,Ord,Show,Typeable) --- | A struct with date, time and zone components. +-- | A struct with date and time zone components. +data DateZoneStruct = DateZoneStruct { + _dz_year :: {-# UNPACK #-} !Year + , _dz_mon :: !Month + , _dz_mday :: {-# UNPACK #-} !Day + , _dz_wday :: !DayOfWeek + , _dz_zone :: !TimeZone + } deriving (Eq,Generic,Ord,Show,Typeable) + +-- | A struct with date, time and time zone components. 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 + _dtz_year :: {-# UNPACK #-} !Year + , _dtz_mon :: !Month + , _dtz_mday :: {-# UNPACK #-} !Day + , _dtz_wday :: !DayOfWeek + , _dtz_hour :: {-# UNPACK #-} !Hour + , _dtz_min :: {-# UNPACK #-} !Minute + , _dtz_sec :: {-# UNPACK #-} !Double + , _dtz_zone :: !TimeZone } deriving (Eq,Generic,Ord,Show,Typeable) -- | Year. newtype Year = Year {getYear :: Int32} - deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) + deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Month. -newtype Month = Month {getMonth :: Int32} - deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +data Month = + January + | February + | March + | April + | May + | June + | July + | August + | September + | October + | November + | December + deriving (Eq,Enum,Generic,Ord,Show,Typeable) -- | Day. newtype Day = Day {getDay :: Int32} - deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) + deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +-- | Day of week. +data DayOfWeek = + Sunday + | Monday + | Tuesday + | Wednesday + | Thursday + | Friday + | Saturday + deriving (Eq,Enum,Generic,Ord,Show,Typeable) + -- | Hour. -newtype Hour = Hour {getHour :: Int32} - deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Hour = Hour {getHour :: Int64} + deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Minute. -newtype Minute = Minute {getMinute :: Int32} - deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Minute = Minute {getMinute :: Int64} + deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Second. -newtype Second = Second {getSecond :: Int32} - deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Second = Second {getSecond :: Int64} + deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Millisecond. -newtype Millis = Millis {getMillis :: Int32} - deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Millis = Millis {getMillis :: Int64} + deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Microsecond. -newtype Micros = Micros {getMicros :: Int32} - deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Micros = Micros {getMicros :: Int64} + deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Nanosecond. -newtype Nanos = Nanos {getNanos :: Int32} - deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) +newtype Nanos = Nanos {getNanos :: Int64} + deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Picosecond. newtype Picos = Picos {getPicos :: Int64} - deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) - --- | Day of the week. -data DayOfWeek = - Sunday - | Monday - | Tuesday - | Wednesday - | Thursday - | Friday - | Saturday - deriving (Eq,Enum,Generic,Ord,Show,Typeable) + deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) instance FromJSON DateStruct -instance FromJSON DateZoneStruct instance FromJSON DateTimeStruct +instance FromJSON DateZoneStruct instance FromJSON DateTimeZoneStruct instance FromJSON DayOfWeek +instance FromJSON Month +instance Random Month where + random = first toEnum . randomR (0, 11) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + instance Random DayOfWeek where - random = first toEnum . randomR (0, 6) - randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + 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 Show Year where show Year {getYear } = show getYear +instance Show Day where show Day {getDay } = show getDay +instance Show Hour where show Hour {getHour } = show getHour +instance Show Minute where show Minute {getMinute} = show getMinute +instance Show Second where show Second {getSecond} = show getSecond +instance Show Millis where show Millis {getMillis} = show getMillis +instance Show Micros where show Micros {getMicros} = show getMicros +instance Show Nanos where show Nanos {getNanos } = show getNanos +instance Show Picos where show Picos {getPicos } = show getPicos instance ToJSON DateStruct -instance ToJSON DateZoneStruct instance ToJSON DateTimeStruct +instance ToJSON DateZoneStruct instance ToJSON DateTimeZoneStruct instance ToJSON DayOfWeek - --- | Show 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 - --- | Show 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" - --- | Show 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 - --- | Return 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" +instance ToJSON Month -- | Decompose 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 +properFracMillis millis = if res == 1000 then (sec + 1, 0) else result + where result@(sec, res) = fmap (round . (*) 1000) $ properFraction millis -- | Decompose 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 +properFracMicros micros = if res == 1000000 then (sec + 1, 0) else result + where result@(sec, res) = fmap (round . (*) 1000000) $ properFraction micros -- | Decompose 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 +properFracNanos nanos = if res == 1000000000 then (sec + 1, 0) else result + where result@(sec, res) = fmap (round . (*) 1000000000) $ properFraction nanos -- | Decompose 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 +properFracPicos picos = if res == 1000000000000 then (sec + 1, 0) else result + where result@(sec, res) = fmap (round . (*) 1000000000000) $ properFraction picos -- | Calculate 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 +epochToDate year month day = + epochToYear year + yearToMonth month leap + day - 1 where leap = isLeapYear year -- | Calculate 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) +epochToYear (Year year) = + Day $ (year - 1970) * 365 + (year - 1969) `div` 004 - + (year - 1901) `div` 100 + (year - 1601) `div` 400 --- | Calculate the number of days that have +-- | Calculate the number of days that have -- elapsed between January 1st and the given month. yearToMonth :: Month -> Bool -> Day -yearToMonth mon leap = +yearToMonth month 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" + case month of + January -> 000; February -> 031; March -> 060; April -> 091 + May -> 121; June -> 152; July -> 182; August -> 213 + September -> 244; October -> 274; November -> 305; December -> 335 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" + case month of + January -> 000; February -> 031; March -> 059; April -> 090 + May -> 120; June -> 151; July -> 181; August -> 212 + September -> 243; October -> 273; November -> 304; December -> 334 --- | Calculate 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 +-- | Calculate the number of seconds (excluding leap seconds) +-- that have elapsed between Unix epoch and the given time. +epochToTime :: Year -> Month -> Day -> Hour -> Minute -> Second -> Second +epochToTime year month day (Hour hour) (Minute minute) (Second second) = + Second $ (days * 86400) + (hour * 3600) + (minute * 60) + second + where days = fromIntegral $ epochToDate year month day -- | Check 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) +isLeapYear year = year `mod` 400 == 0 || (year `mod` 100 /= 0 && year `mod` 4 == 0) + +-- | Show the pariod (ante or post meridiem) of the given hour. +showPeriod :: Hour -> String +showPeriod hour = if hour < 12 then "AM" else "PM" + +-- | Show the suffix of the given day of the month. +showSuffix :: Day -> String +showSuffix (Day day) = + if day < 1 || 31 < day + then error $ "showSuffix: unknown day of month" + else case day `mod` 10 of + 1 | day /= 11 -> "st" + 2 | day /= 12 -> "nd" + 3 | day /= 13 -> "rd" + _ -> "th" diff --git a/src/Data/Time/Exts/C.hsc b/src/Data/Time/Exts/C.hsc --- a/src/Data/Time/Exts/C.hsc +++ b/src/Data/Time/Exts/C.hsc @@ -1,11 +1,11 @@ ------------------------------------------------------------------------------ --- Copyright (c) 2013, Enzo Haussecker, Nathan Howell. All rights reserved. -- +-- Copyright (c) 2014, Enzo Haussecker, Nathan Howell. All rights reserved. -- ------------------------------------------------------------------------------ {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS -Wall #-} --- | This module was generated by hsc2hs for profiling, testing and benchmarking purposes. +-- | Haskell bindings to the C time library. module Data.Time.Exts.C where import Data.Convertible (Convertible(..)) @@ -60,4 +60,4 @@ 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 + getResult _ err = error $ "getTimeOfDay: " ++ show err diff --git a/src/Data/Time/Exts/Local.hs b/src/Data/Time/Exts/Local.hs --- a/src/Data/Time/Exts/Local.hs +++ b/src/Data/Time/Exts/Local.hs @@ -1,1142 +1,1281 @@ --------------------------------------------------------------- --- 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 #-} - --- | Types and functions for local timestamps. -module Data.Time.Exts.Local ( - - -- * Local Class - Local - - -- * Local Timestamps - , LocalDate(..) - , LocalDateTime(..) - , LocalDateTimeMillis(..) - , LocalDateTimeMicros(..) - , LocalDateTimeNanos(..) - , LocalDateTimePicos(..) - - -- * Create Local Timestamps - , createLocalDate - , createLocalDateTime - , createLocalDateTimeMillis - , createLocalDateTimeMicros - , createLocalDateTimeNanos - , createLocalDateTimePicos - - -- * Get Current Local Timestamps - , getCurrentLocalDate - , getCurrentLocalDateTime - , getCurrentLocalDateTimeMillis - , getCurrentLocalDateTimeMicros - , getCurrentLocalDateTimeNanos - , getCurrentLocalDateTimePicos - - -- Get Current Local Timestamps Using Preloaded Transition Times - , getCurrentLocalDate' - , getCurrentLocalDateTime' - , getCurrentLocalDateTimeMillis' - , getCurrentLocalDateTimeMicros' - , getCurrentLocalDateTimeNanos' - , getCurrentLocalDateTimePicos' - - -- * Transition Times - , TransitionTimes - , getTransitionTimes - - -- * Base Conversions - , 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) - --- | A class of local timestamps. -class Local x - --- | A local date. -data LocalDate = LocalDate { - _loc_day_base :: {-# UNPACK #-} !Int32 -- ^ days since Unix epoch - , _loc_day_zone :: {-# UNPACK #-} !Int16 -- ^ enumerated time zone - } deriving (Eq,Generic,Typeable) - --- | A local date and time. -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) - --- | A local date and time with millisecond granularity. -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) - --- | A local date and time with microsecond granularity. -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) - --- | A local date and time with nanosecond granularity. -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) - --- | A local date and time with picosecond granularity. -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) - --- | A list of transition times. -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 17 - where base = fromInteger toModifiedJulianDay - 40587 - -instance Convertible UTCTime LocalDateTime where - safeConvert UTCTime{..} = Right $ LocalDateTime base 17 - where days = fromInteger (Calendar.toModifiedJulianDay utctDay) - 40587 - base = baseUnixToUTC $ days * 86400 + truncate utctDayTime - -instance Convertible UTCTime LocalDateTimeMillis where - safeConvert UTCTime{..} = Right $ LocalDateTimeMillis base mill 17 - 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 17 - 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 17 - 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 17 - 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 (minTime, maxTime) g of { (base_mill, g' ) -> - case randomR (minZone, maxZone) g' of { (zone , g'') -> - let (base, mill) = (***) fromInteger fromInteger $ divMod base_mill 1000 - in (LocalDateTimeMillis base mill zone, g'') } } - where minTime = toInteger (_loc_mil_mill a) + toInteger (_loc_mil_base a) * 1000 - maxTime = toInteger (_loc_mil_mill b) + toInteger (_loc_mil_base b) * 1000 - minZone = _loc_mil_zone a - maxZone = _loc_mil_zone b - -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 (minTime, maxTime) g of { (base_micr, g' ) -> - case randomR (minZone, maxZone) g' of { (zone , g'') -> - let (base, micr) = (***) fromInteger fromInteger $ divMod base_micr 1000000 - in (LocalDateTimeMicros base micr zone, g'') } } - where minTime = toInteger (_loc_mic_micr a) + toInteger (_loc_mic_base a) * 1000000 - maxTime = toInteger (_loc_mic_micr b) + toInteger (_loc_mic_base b) * 1000000 - minZone = _loc_mic_zone a - maxZone = _loc_mic_zone b - -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 (minTime, maxTime) g of { (base_nano, g' ) -> - case randomR (minZone, maxZone) g' of { (zone , g'') -> - let (base, nano) = (***) fromInteger fromInteger $ divMod base_nano 1000000000 - in (LocalDateTimeNanos base nano zone, g'') } } - where minTime = toInteger (_loc_nan_nano a) + toInteger (_loc_nan_base a) * 1000000000 - maxTime = toInteger (_loc_nan_nano b) + toInteger (_loc_nan_base b) * 1000000000 - minZone = _loc_nan_zone a - maxZone = _loc_nan_zone b - -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 (minTime, maxTime) g of { (base_pico, g' ) -> - case randomR (minZone, maxZone) g' of { (zone , g'') -> - let (base, pico) = (***) fromInteger fromInteger $ divMod base_pico 1000000000000 - in (LocalDateTimePicos base pico zone, g'') } } - where minTime = toInteger (_loc_pic_pico a) + toInteger (_loc_pic_base a) * 1000000000000 - maxTime = toInteger (_loc_pic_pico b) + toInteger (_loc_pic_base b) * 1000000000000 - minZone = _loc_pic_zone a - maxZone = _loc_pic_zone b - -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 - --- | Create a local date. --- --- > >>> createLocalDate 2013 11 03 Pacific_Standard_Time --- > 2013-11-03 PST --- -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 - --- | Create a local date and time. --- --- > >>> createLocalDateTime 2013 11 03 22 55 52 South_Africa_Standard_Time --- > 2013-11-03 22:55:52 SAST --- -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) - - (getOffset zone * 00060)) + fromIntegral second - --- | Create a local date and time with millisecond granularity. --- --- > >>> createLocalDateTimeMillis 2013 11 03 13 57 43 830 Mountain_Standard_Time --- > 2013-11-03 13:57:43.830 MST --- -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) - - (getOffset zone * 00060)) + fromIntegral second + adds - --- | Create a local date and time with microsecond granularity. --- --- > >>> createLocalDateTimeMicros 2013 11 03 21 01 42 903539 Coordinated_Universal_Time --- > 2013-11-03 21:01:42.903539 UTC --- -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) - - (getOffset zone * 00060)) + fromIntegral second + adds - --- | Create a local date and time with nanosecond granularity. --- --- > >>> createLocalDateTimeNanos 2013 11 04 06 05 07 016715087 Japan_Standard_Time --- > 2013-11-04 06:05:07.016715087 JST --- -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) - - (getOffset zone * 00060)) + fromIntegral second + adds - --- | Create a local date and time with picosecond granularity. --- --- > >>> createLocalDateTimePicos 2013 11 03 23 13 56 838238648311 Eastern_European_Time --- > 2013-11-03 23:13:56.838238648311 EET --- -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) - - (getOffset zone * 00060)) + fromIntegral second + adds - --- | Decompose 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 - --- | Decompose 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` (getOffset zone :: Minute) - sec = _dt_sec + fromIntegral leap - --- | Decompose 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` (getOffset zone :: Minute) - sec = _dt_sec + fromIntegral leap + fromIntegral _loc_mil_mill / 1000 - --- | Decompose 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` (getOffset zone :: Minute) - sec = _dt_sec + fromIntegral leap + fromIntegral _loc_mic_micr / 1000000 - --- | Decompose 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` (getOffset zone :: Minute) - sec = _dt_sec + fromIntegral leap + fromIntegral _loc_nan_nano / 1000000000 - --- | Decompose 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` (getOffset zone :: Minute) - sec = _dt_sec + fromIntegral leap + fromIntegral _loc_pic_pico / 1000000000000 - --- | Decompose 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 * getOffset zoneNum - newBase = fromIntegral (offBase `div` 86400) - newSecs = fromIntegral (nixBase `mod` 86400) + fromIntegral leapSec - --- | Get the current local date from the system clock. --- --- > >>> getCurrentLocalDate London --- > 2013-11-03 GMT --- -getCurrentLocalDate :: City -> IO LocalDate -getCurrentLocalDate city = getTransitionTimes city >>= getCurrentLocalDateTime' >>= return . convert - --- | Get the current local date from the system clock using preloaded transition times. --- --- > >>> ttimes <- getTransitionTimes Tokyo --- > >>> getCurrentLocalDate' ttimes --- > 2013-11-04 JST --- --- Use this function if you need to get the current local date more than once. The --- use of preloaded transition times will avoid unnecessary parsing of Olson files. -getCurrentLocalDate' :: TransitionTimes -> IO LocalDate -getCurrentLocalDate' ttimes = getCurrentLocalDateTime' ttimes >>= return . convert - --- | Get the current local date and time from the system clock. --- --- > >>> getCurrentLocalDateTime New_York --- > 2013-11-03 16:38:16 EST --- -getCurrentLocalDateTime :: City -> IO LocalDateTime -getCurrentLocalDateTime city = getTransitionTimes city >>= getCurrentLocalDateTime' - --- | Get the current local date and time from the system clock using preloaded transition --- times. --- --- > >>> ttimes <- getTransitionTimes Moscow --- > >>> getCurrentLocalDateTime' ttimes --- > 2013-11-04 01:41:50 MSK --- --- Use this function if you need to get the current local date and time more than once. --- The use of preloaded transition times will avoid unnecessary parsing of Olson files. -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 - --- | Get the current local date and time with millisecond granularity from the system clock. --- --- > >>> getCurrentLocalDateTimeMillis Auckland --- > 2013-11-04 10:46:13.123 NZDT --- -getCurrentLocalDateTimeMillis :: City -> IO LocalDateTimeMillis -getCurrentLocalDateTimeMillis city = getTransitionTimes city >>= getCurrentLocalDateTimeMillis' - --- | Get the current local date and time with millisecond granularity from the system clock --- using preloaded transition times. --- --- > >>> ttimes <- getTransitionTimes Tehran --- > >>> getCurrentLocalDateTimeMillis' ttimes --- > 2013-11-04 01:20:49.435 IRST --- --- Use this function if you need to get the current local date and time with millisecond --- granularity more than once. The use of preloaded transition times will avoid unnecessary --- parsing of Olson files. -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 - --- | Get the current local date and time with microsecond granularity from the system clock. --- --- > >>> getCurrentLocalDateTimeMicros Tel_Aviv --- > 2013-11-03 23:55:30.935387 IST --- -getCurrentLocalDateTimeMicros :: City -> IO LocalDateTimeMicros -getCurrentLocalDateTimeMicros city = getTransitionTimes city >>= getCurrentLocalDateTimeMicros' - --- | Get the current local date and time with microsecond granularity from the system clock --- using preloaded transition times. --- --- > >>> ttimes <- getTransitionTimes Sao_Paulo --- > >>> getCurrentLocalDateTimeMicros' ttimes --- > 2013-11-03 19:58:50.405806 BRST --- --- Use this function if you need to get the current local date and time with microsecond --- granularity more than once. The use of preloaded transition times will avoid unnecessary --- parsing of Olson files. -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 - --- | Get the current local date and time with nanosecond granularity from the system clock. --- --- > >>> getCurrentLocalDateTimeNanos Brussels --- > 2013-11-03 23:01:07.337488000 CET --- --- Note that this functions calls @gettimeofday()@ behind the scenes. Therefore, the resultant --- timestamp will have nanosecond granularity, but only microsecond resolution. -getCurrentLocalDateTimeNanos :: City -> IO LocalDateTimeNanos -getCurrentLocalDateTimeNanos city = getTransitionTimes city >>= getCurrentLocalDateTimeNanos' - --- | Get the current local date and time with nanosecond granularity from the system clock --- using preloaded transition times. --- --- > >>> ttimes <- getTransitionTimes Mogadishu --- > >>> getCurrentLocalDateTimeNanos' ttimes --- > 2013-11-04 01:15:08.664426000 EAT --- --- Use this function if you need to get the current local date and time with nanosecond --- granularity more than once. The use of preloaded transition times will avoid unnecessary --- parsing of Olson files. --- --- Note that this functions calls @gettimeofday()@ behind the scenes. Therefore, the resultant --- timestamp will have nanosecond granularity, but only microsecond resolution. -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 - --- | Get the current local date and time with picosecond granularity from the system clock. --- --- > >>> getCurrentLocalDateTime Karachi --- > 2013-11-04 03:18:30 PKT --- --- Note that this functions calls @gettimeofday()@ behind the scenes. Therefore, the resultant --- timestamp will have picosecond granularity, but only microsecond resolution. -getCurrentLocalDateTimePicos :: City -> IO LocalDateTimePicos -getCurrentLocalDateTimePicos city = getTransitionTimes city >>= getCurrentLocalDateTimePicos' - --- | Get the current local date and time with picosecond granularity from the system clock using --- preloaded transition times. --- --- > >>> ttimes <- getTransitionTimes Baghdad --- > >>> getCurrentLocalDateTimePicos' ttimes --- > 2013-11-04 01:20:57.502906000000 AST --- --- Use this function if you need to get the current local date and time with picosecond --- granularity more than once. The use of preloaded transition times will avoid unnecessary --- parsing of Olson files. --- --- Note that this functions calls @gettimeofday()@ behind the scenes. Therefore, the resultant --- timestamp will have picosecond granularity, but only microsecond resolution. -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 - --- | Show 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) - --- | Show 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 - --- | Get a list 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) - --- | Convert 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 - --- | Convert 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 +-- Copyright (c) 2014, Enzo Haussecker. All rights reserved. -- +--------------------------------------------------------------- + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS -Wall #-} + +-- | Local timestamps of varying granularity. +module Data.Time.Exts.Local ( + + -- ** Local Class + Local(..) + + -- ** Local Timestamps + , LocalDate(..) + , LocalDateTime(..) + , LocalDateTimeMillis(..) + , LocalDateTimeMicros(..) + , LocalDateTimeNanos(..) + , LocalDateTimePicos(..) + + -- ** Create Local Timestamps + , createLocalDate + , createLocalDateTime + , createLocalDateTimeMillis + , createLocalDateTimeMicros + , createLocalDateTimeNanos + , createLocalDateTimePicos + + -- ** Get Current Local Timestamps + , getCurrentLocalDate + , getCurrentLocalDateTime + , getCurrentLocalDateTimeMillis + , getCurrentLocalDateTimeMicros + , getCurrentLocalDateTimeNanos + , getCurrentLocalDateTimePicos + + -- ** Time Zone Transition Times + , Transition(..) + , getTransitions + + -- ** Get Current Local Timestamps Using Preloaded Time Zone Transitions Times + , getCurrentLocalDate' + , getCurrentLocalDateTime' + , getCurrentLocalDateTimeMillis' + , getCurrentLocalDateTimeMicros' + , getCurrentLocalDateTimeNanos' + , getCurrentLocalDateTimePicos' + + -- ** Pretty Local Timestamps + , prettyLocalDate + , prettyLocalDateTime + + ) where + +import Control.Arrow ((***), first) +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 (DiffTime, UTCTime(..)) +import qualified Data.Time.Calendar as Cal (Day(..)) +import Data.Time.Exts.Base +import Data.Time.Exts.Unix +import Data.Time.Exts.Zone +import qualified Data.Time.LocalTime.TimeZone.Olson as Olson +import Data.Tuple (swap) +import Data.Typeable (Typeable) +import Data.Word (Word8) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (Storable(..)) +import GHC.Generics (Generic) +import System.Random (Random(..)) +import Text.Printf (printf) + +-- | The local timestamp type class. +class Local u where + + -- | Get the base component of a local timestamp. + localBase :: u -> Int64 + + -- | Get the zone component of a local timestamp. + localZone :: u -> Word8 + +-- | Days since Unix epoch. +data LocalDate = LocalDate { + _loc_day_base :: {-# UNPACK #-} !Int32 + , _loc_day_zone :: {-# UNPACK #-} !Word8 + } deriving (Eq,Generic,Typeable) + +-- | Seconds since Unix epoch (including leap seconds). +data LocalDateTime = LocalDateTime { + _loc_sec_base :: {-# UNPACK #-} !Int64 + , _loc_sec_zone :: {-# UNPACK #-} !Word8 + } deriving (Eq,Generic,Typeable) + +-- | Milliseconds since Unix epoch (including leap seconds). +data LocalDateTimeMillis = LocalDateTimeMillis { + _loc_mil_base :: {-# UNPACK #-} !Int64 + , _loc_mil_zone :: {-# UNPACK #-} !Word8 + } deriving (Eq,Generic,Typeable) + +-- | Microseconds since Unix epoch (including leap seconds). +data LocalDateTimeMicros = LocalDateTimeMicros { + _loc_mic_base :: {-# UNPACK #-} !Int64 + , _loc_mic_zone :: {-# UNPACK #-} !Word8 + } deriving (Eq,Generic,Typeable) + +-- | Nanoseconds since Unix epoch (including leap seconds). +data LocalDateTimeNanos = LocalDateTimeNanos { + _loc_nan_base :: {-# UNPACK #-} !Int64 + , _loc_nan_nano :: {-# UNPACK #-} !Int16 + , _loc_nan_zone :: {-# UNPACK #-} !Word8 + } deriving (Eq,Generic,Typeable) + +-- | Picoseconds since Unix epoch (including leap seconds). +data LocalDateTimePicos = LocalDateTimePicos { + _loc_pic_base :: {-# UNPACK #-} !Int64 + , _loc_pic_pico :: {-# UNPACK #-} !Int32 + , _loc_pic_zone :: {-# UNPACK #-} !Word8 + } deriving (Eq,Generic,Typeable) + +-- | Time zone transition time. +newtype Transition = Transition { + unboxTrans :: LocalDateTime + } deriving (Eq,Typeable,Generic,ToJSON,FromJSON,NFData,Storable) + +instance FromJSON LocalDate +instance FromJSON LocalDateTime +instance FromJSON LocalDateTimeMillis +instance FromJSON LocalDateTimeMicros +instance FromJSON LocalDateTimeNanos +instance FromJSON LocalDateTimePicos + +instance NFData LocalDate +instance NFData LocalDateTime +instance NFData LocalDateTimeMillis +instance NFData LocalDateTimeMicros +instance NFData LocalDateTimeNanos +instance NFData LocalDateTimePicos + +instance Storable LocalDate where + sizeOf _ = 5 + alignment = sizeOf + peekElemOff ptr n = do + let off = 5 * n + base <- peek . plusPtr ptr $ off + zone <- peek . plusPtr ptr $ off + 4 + return $! LocalDate base zone + pokeElemOff ptr n LocalDate{..} = do + let off = 5 * n + poke (plusPtr ptr $ off ) _loc_day_base + poke (plusPtr ptr $ off + 4) _loc_day_zone + +instance Storable LocalDateTime where + sizeOf _ = 9 + alignment = sizeOf + peekElemOff ptr n = do + let off = 9 * n + base <- peek . plusPtr ptr $ off + zone <- peek . plusPtr ptr $ off + 8 + return $! LocalDateTime base zone + pokeElemOff ptr n LocalDateTime{..} = do + let off = 9 * n + poke (plusPtr ptr $ off ) _loc_sec_base + poke (plusPtr ptr $ off + 8) _loc_sec_zone + +instance Storable LocalDateTimeMillis where + sizeOf _ = 9 + alignment = sizeOf + peekElemOff ptr n = do + let off = 9 * n + base <- peek . plusPtr ptr $ off + zone <- peek . plusPtr ptr $ off + 8 + return $! LocalDateTimeMillis base zone + pokeElemOff ptr n LocalDateTimeMillis{..} = do + let off = 9 * n + poke (plusPtr ptr $ off ) _loc_mil_base + poke (plusPtr ptr $ off + 8) _loc_mil_zone + +instance Storable LocalDateTimeMicros where + sizeOf _ = 9 + alignment = sizeOf + peekElemOff ptr n = do + let off = 9 * n + base <- peek . plusPtr ptr $ off + zone <- peek . plusPtr ptr $ off + 8 + return $! LocalDateTimeMicros base zone + pokeElemOff ptr n LocalDateTimeMicros{..} = do + let off = 9 * n + poke (plusPtr ptr $ off ) _loc_mic_base + poke (plusPtr ptr $ off + 8) _loc_mic_zone + +instance Storable LocalDateTimeNanos where + sizeOf _ = 11 + alignment = sizeOf + peekElemOff ptr n = do + let off = 11 * n + base <- peek . plusPtr ptr $ off + nano <- peek . plusPtr ptr $ off + 08 + zone <- peek . plusPtr ptr $ off + 10 + return $! LocalDateTimeNanos base nano zone + pokeElemOff ptr n LocalDateTimeNanos{..} = do + let off = 11 * n + poke (plusPtr ptr $ off ) _loc_nan_base + poke (plusPtr ptr $ off + 08) _loc_nan_nano + poke (plusPtr ptr $ off + 10) _loc_nan_zone + +instance Storable LocalDateTimePicos where + sizeOf _ = 13 + alignment = sizeOf + peekElemOff ptr n = do + let off = 13 * n + base <- peek . plusPtr ptr $ off + pico <- peek . plusPtr ptr $ off + 08 + zone <- peek . plusPtr ptr $ off + 12 + return $! LocalDateTimePicos base pico zone + pokeElemOff ptr n LocalDateTimePicos{..} = do + let off = 13 * n + poke (plusPtr ptr $ off ) _loc_pic_base + poke (plusPtr ptr $ off + 08) _loc_pic_pico + poke (plusPtr ptr $ off + 12) _loc_pic_zone + +instance ToJSON LocalDate +instance ToJSON LocalDateTime +instance ToJSON LocalDateTimeMillis +instance ToJSON LocalDateTimeMicros +instance ToJSON LocalDateTimeNanos +instance ToJSON LocalDateTimePicos + +mkLabels [ ''LocalDate + , ''LocalDateTime + , ''LocalDateTimeMillis + , ''LocalDateTimeMicros + , ''LocalDateTimeNanos + , ''LocalDateTimePicos + ] + +instance Bounded LocalDate where + minBound = LocalDate 0 0 + maxBound = LocalDate 2932896 maxZone + +instance Bounded LocalDateTime where + minBound = LocalDateTime 43200 0 + maxBound = LocalDateTime 253402257624 maxZone + +instance Bounded LocalDateTimeMillis where + minBound = LocalDateTimeMillis 43200000 0 + maxBound = LocalDateTimeMillis 253402257624999 maxZone + +instance Bounded LocalDateTimeMicros where + minBound = LocalDateTimeMicros 43200000000 0 + maxBound = LocalDateTimeMicros 253402257624999999 maxZone + +instance Bounded LocalDateTimeNanos where + minBound = LocalDateTimeNanos 43200000000 0 0 + maxBound = LocalDateTimeNanos 253402257624999999 999 maxZone + +instance Bounded LocalDateTimePicos where + minBound = LocalDateTimePicos 43200000000 0 0 + maxBound = LocalDateTimePicos 253402257624999999 999999 maxZone + +deriving instance Bounded Transition + +instance Local LocalDate where + localBase = fromIntegral . get loc_day_base + localZone = get loc_day_zone + +instance Local LocalDateTime where + localBase = get loc_sec_base + localZone = get loc_sec_zone + +instance Local LocalDateTimeMillis where + localBase = get loc_mil_base + localZone = get loc_mil_zone + +instance Local LocalDateTimeMicros where + localBase = get loc_mic_base + localZone = get loc_mic_zone + +instance Local LocalDateTimeNanos where + localBase = get loc_nan_base + localZone = get loc_nan_zone + +instance Local LocalDateTimePicos where + localBase = get loc_pic_base + localZone = get loc_pic_zone + +deriving instance Local Transition + +instance Ord LocalDate where + compare = comparing localBase + +instance Ord LocalDateTime where + compare = comparing localBase + +instance Ord LocalDateTimeMillis where + compare = comparing localBase + +instance Ord LocalDateTimeMicros where + compare = comparing localBase + +instance Ord LocalDateTimeNanos where + compare = comparing localBase <> comparing (get loc_nan_nano) + +instance Ord LocalDateTimePicos where + compare = comparing localBase <> comparing (get loc_pic_pico) + +deriving instance Ord Transition + +instance DateTimeMath LocalDate Day where + date `plus` Day day = + check "plus{LocalDate,Day}" $ + modify loc_day_base (+ day) date + +instance DateTimeMath LocalDateTime Second where + time `plus` Second second = + check "plus{LocalDateTime,Second}" $ + modify loc_sec_base (+ second) time + +instance DateTimeMath LocalDateTimeMillis Second where + time `plus` Second second = + check "plus{LocalDateTimeMillis,Second}" $ + modify loc_mil_base (+ second * 1000) time + +instance DateTimeMath LocalDateTimeMicros Second where + time `plus` Second second = + check "plus{LocalDateTimeMicros,Second}" $ + modify loc_mic_base (+ second * 1000000) time + +instance DateTimeMath LocalDateTimeNanos Second where + time `plus` Second second = + check "plus{LocalDateTimeNanos,Second}" $ + modify loc_nan_base (+ second * 1000000) time + +instance DateTimeMath LocalDateTimePicos Second where + time `plus` Second second = + check "plus{LocalDateTimePicos,Second}" $ + modify loc_pic_base (+ second * 1000000) time + +instance DateTimeMath LocalDateTimeMillis Millis where + time `plus` Millis millis = + check "plus{LocalDateTimeMillis,Millis}" $ + modify loc_mil_base (+ millis) time + +instance DateTimeMath LocalDateTimeMicros Millis where + time `plus` Millis millis = + check "plus{LocalDateTimeMicros,Millis}" $ + modify loc_mic_base (+ millis * 1000) time + +instance DateTimeMath LocalDateTimeNanos Millis where + time `plus` Millis millis = + check "plus{LocalDateTimeNanos,Millis}" $ + modify loc_nan_base (+ millis * 1000) time + +instance DateTimeMath LocalDateTimePicos Millis where + time `plus` Millis millis = + check "plus{LocalDateTimePicos,Millis}" $ + modify loc_pic_base (+ millis * 1000) time + +instance DateTimeMath LocalDateTimeMicros Micros where + time `plus` Micros micros = + check "plus{LocalDateTimeMicros,Micros}" $ + modify loc_mic_base (+ micros) time + +instance DateTimeMath LocalDateTimeNanos Micros where + time `plus` Micros micros = + check "plus{LocalDateTimeNanos,Micros}" $ + modify loc_nan_base (+ micros) time + +instance DateTimeMath LocalDateTimePicos Micros where + time `plus` Micros micros = + check "plus{LocalDateTimePicos,Micros}" $ + modify loc_pic_base (+ micros) time + +instance DateTimeMath LocalDateTimeNanos Nanos where + time `plus` Nanos nanos = + check "plus{UnixDateTimeNanos,Nanos}" . + modify loc_nan_base (+ micros) $ + set loc_nan_nano nano time + where nsum = fromIntegral (get loc_nan_nano time) + nanos + (micros, nano) = fmap fromIntegral $ divMod nsum 1000 + +instance DateTimeMath LocalDateTimePicos Nanos where + time `plus` Nanos nanos = + check "plus{LocalDateTimePicos,Nanos}" . + modify loc_pic_base (+ micros) $ + set loc_pic_pico pico time + where psum = fromIntegral (get loc_pic_pico time) + nanos * 1000 + (micros, pico) = fmap fromIntegral $ divMod psum 1000000 + +instance DateTimeMath LocalDateTimePicos Picos where + time `plus` Picos picos = + check "plus{LocalDateTimePicos,Picos}" . + modify loc_pic_base (+ micros) $ + set loc_pic_pico pico time + where psum = fromIntegral (get loc_pic_pico time) + picos + (micros, pico) = fmap fromIntegral $ divMod psum 1000000 + +instance Enum LocalDate where + succ = flip plus $ Day 1 + pred = flip plus . Day $ - 1 + toEnum = check "toEnum{LocalDate}" . uncurry LocalDate . doubleIntegral . flip divMod 1000 + fromEnum LocalDate{..} = fromIntegral _loc_day_base * 1000 + fromIntegral _loc_day_zone + enumFrom v = [t | t <- v : enumFrom (succ v)] + enumFromTo v1 v2 + | v1 == v2 = [v1] + | v1 < v2 = [t | t <- v1 : enumFromTo (succ v1) v2] + | otherwise = [t | t <- v1 : enumFromTo (pred v1) v2] + +instance Enum LocalDateTime where + succ = flip plus $ Second 1 + pred = flip plus . Second $ - 1 + toEnum = check "toEnum{LocalDateTime}" . uncurry LocalDateTime . doubleIntegral . flip divMod 1000 + fromEnum LocalDateTime{..} = fromIntegral _loc_sec_base * 1000 + fromIntegral _loc_sec_zone + enumFrom v = [t | t <- v : enumFrom (succ v)] + enumFromTo v1 v2 + | v1 == v2 = [v1] + | v1 < v2 = [t | t <- v1 : enumFromTo (succ v1) v2] + | otherwise = [t | t <- v1 : enumFromTo (pred v1) v2] + +instance Enum LocalDateTimeMillis where + succ = flip plus $ Millis 1 + pred = flip plus . Millis $ - 1 + toEnum = check "toEnum{LocalDateTimeMillis}" . uncurry LocalDateTimeMillis . doubleIntegral . flip divMod 1000 + fromEnum LocalDateTimeMillis{..} = fromIntegral _loc_mil_base * 1000 + fromIntegral _loc_mil_zone + enumFrom v = [t | t <- v : enumFrom (succ v)] + enumFromTo v1 v2 + | v1 == v2 = [v1] + | v1 < v2 = [t | t <- v1 : enumFromTo (succ v1) v2] + | otherwise = [t | t <- v1 : enumFromTo (pred v1) v2] + +deriving instance Enum Transition + +-- | Convert Unix seconds into a UTC seconds. +baseUnixToUTC :: Int64 -> Int64 +baseUnixToUTC base + | 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 + +-- | Create a local date. +-- +-- > >>> createLocalDate 2013 November 03 Pacific_Standard_Time +-- > 2013-11-03 PST +-- +createLocalDate :: Year -> Month -> Day -> TimeZone -> LocalDate +createLocalDate year month day zone = + check "createLocalDate" . LocalDate base $ fromZone zone + where Day base = epochToDate year month day + +-- | Create a local date and time. +-- +-- > >>> createLocalDateTime 2013 November 03 22 55 52 South_Africa_Standard_Time +-- > 2013-11-03 22:55:52 SAST +-- +createLocalDateTime :: Year -> Month -> Day -> Hour -> Minute -> Second -> TimeZone -> LocalDateTime +createLocalDateTime year month day hour minute (Second second) zone = + check "createLocalDateTime" . LocalDateTime base $ fromZone zone + where base = baseUnixToUTC (unix - offset) + second + Second unix = epochToTime year month day hour minute 0 + offset = getUTCOffset zone * 60 + +-- | Create a local date and time with millisecond granularity. +-- +-- > >>> createLocalDateTimeMillis 2013 November 03 13 57 43 830 Mountain_Standard_Time +-- > 2013-11-03 13:57:43.830 MST +-- +createLocalDateTimeMillis :: Year -> Month -> Day -> Hour -> Minute -> Second -> Millis -> TimeZone -> LocalDateTimeMillis +createLocalDateTimeMillis year month day hour minute (Second second) (Millis millis) zone = + check "createLocalDateTimeMillis" . LocalDateTimeMillis base $ fromZone zone + where base = 1000 * (baseUnixToUTC (unix - offset) + second) + millis + Second unix = epochToTime year month day hour minute 0 + offset = getUTCOffset zone * 60 + +-- | Create a local date and time with microsecond granularity. +-- +-- > >>> createLocalDateTimeMicros 2013 November 03 21 01 42 903539 Coordinated_Universal_Time +-- > 2013-11-03 21:01:42.903539 UTC +-- +createLocalDateTimeMicros :: Year -> Month -> Day -> Hour -> Minute -> Second -> Micros -> TimeZone -> LocalDateTimeMicros +createLocalDateTimeMicros year month day hour minute (Second second) (Micros micros) zone = + check "createLocalDateTimeMicros" . LocalDateTimeMicros base $ fromZone zone + where base = 1000000 * (baseUnixToUTC (unix - offset) + second) + micros + Second unix = epochToTime year month day hour minute 0 + offset = getUTCOffset zone * 60 + +-- | Create a local date and time with nanosecond granularity. +-- +-- > >>> createLocalDateTimeNanos 2013 November 04 06 05 07 016715087 Japan_Standard_Time +-- > 2013-11-04 06:05:07.016715087 JST +-- +createLocalDateTimeNanos :: Year -> Month -> Day -> Hour -> Minute -> Second -> Nanos -> TimeZone -> LocalDateTimeNanos +createLocalDateTimeNanos year month day hour minute (Second second) (Nanos nanos) zone = + check "createLocalDateTimeNanos" . LocalDateTimeNanos base nano $ fromZone zone + where base = 1000000 * (baseUnixToUTC (unix - offset) + second) + micros + (micros, nano) = fmap fromIntegral $ divMod nanos 0001000 + Second unix = epochToTime year month day hour minute 0 + offset = getUTCOffset zone * 60 + +-- | Create a local date and time with picosecond granularity. +-- +-- > >>> createLocalDateTimePicos 2013 November 03 23 13 56 838238648311 Eastern_European_Time +-- > 2013-11-03 23:13:56.838238648311 EET +-- +createLocalDateTimePicos :: Year -> Month -> Day -> Hour -> Minute -> Second -> Picos -> TimeZone -> LocalDateTimePicos +createLocalDateTimePicos year month day hour minute (Second second) (Picos picos) zone = + check "createLocalDateTimePicos" . LocalDateTimePicos base pico $ fromZone zone + where base = 1000000 * (baseUnixToUTC (unix - offset) + second) + micros + (micros, pico) = fmap fromIntegral $ divMod picos 1000000 + Second unix = epochToTime year month day hour minute 0 + offset = getUTCOffset zone * 60 + +-- | Convert UTC seconds into Unix and leap seconds. +baseUTCToUnix :: Int64 -> (Int64, Double) +baseUTCToUnix base + | 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) + +-- | Decompose 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 $ UnixDate _loc_day_base + zone = toZone _loc_day_zone + +-- | Decompose 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 $ UnixDateTime base `plus` offset + (base, leap) = baseUTCToUnix _loc_sec_base + sec = _dt_sec + leap + offset = getUTCOffset zone :: Minute + zone = toZone _loc_sec_zone + +-- | Decompose 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 $ UnixDateTime base `plus` offset + ((base, leap), millis) = baseUTCToUnix *** realToFrac $ divMod _loc_mil_base 0001000 + sec = _dt_sec + leap + millis / 0001000 + offset = getUTCOffset zone :: Minute + zone = toZone _loc_mil_zone + +-- | Decompose 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 $ UnixDateTime base `plus` offset + ((base, leap), micros) = baseUTCToUnix *** realToFrac $ divMod _loc_mic_base 1000000 + sec = _dt_sec + leap + micros / 1000000 + offset = getUTCOffset zone :: Minute + zone = toZone _loc_mic_zone + +-- | Decompose 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 $ UnixDateTime base `plus` offset + ((base, leap), micros) = baseUTCToUnix *** realToFrac $ divMod _loc_nan_base 1000000 + sec = _dt_sec + leap + micros / 1000000 + realToFrac _loc_nan_nano / 1000000000 + offset = getUTCOffset zone :: Minute + zone = toZone _loc_nan_zone + +-- | Decompose 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 $ UnixDateTime base `plus` offset + ((base, leap), micros) = baseUTCToUnix *** realToFrac $ divMod _loc_pic_base 1000000 + sec = _dt_sec + leap + micros / 1000000 + realToFrac _loc_pic_pico / 1000000000000 + offset = getUTCOffset zone :: Minute + zone = toZone _loc_pic_zone + +-- | Decompose a local base (in seconds) into day and second components. +decompLocalBase :: (Int64, TimeZone) -> (Int32, DiffTime) +decompLocalBase = uncurry (flip f) . first (uncurry g . baseUTCToUnix) + where f x = first $ fromIntegral . flip div 86400 . (+ 60 * getUTCOffset x) + g x = (x, ) . fromIntegral . (+ mod x 86400) . truncate + +instance Convertible LocalDateTime LocalDate where + safeConvert LocalDateTime{..} = Right $ LocalDate base _loc_sec_zone + where base = fst $ decompLocalBase (_loc_sec_base, toZone _loc_sec_zone) + +instance Convertible LocalDateTimeMillis LocalDate where + safeConvert LocalDateTimeMillis{..} = Right $ LocalDate base _loc_mil_zone + where base = fst (decompLocalBase (div _loc_mil_base 0001000, toZone _loc_mil_zone)) + +instance Convertible LocalDateTimeMicros LocalDate where + safeConvert LocalDateTimeMicros{..} = Right $ LocalDate base _loc_mic_zone + where base = fst (decompLocalBase (div _loc_mic_base 1000000, toZone _loc_mic_zone)) + +instance Convertible LocalDateTimeNanos LocalDate where + safeConvert LocalDateTimeNanos{..} = Right $ LocalDate base _loc_nan_zone + where base = fst (decompLocalBase (div _loc_nan_base 1000000, toZone _loc_nan_zone)) + +instance Convertible LocalDateTimePicos LocalDate where + safeConvert LocalDateTimePicos{..} = Right $ LocalDate base _loc_pic_zone + where base = fst (decompLocalBase (div _loc_pic_base 1000000, toZone _loc_pic_zone)) + +instance Convertible LocalDate Cal.Day where + safeConvert = Right . Cal.ModifiedJulianDay . toInteger . (+ 40587) . _loc_day_base + +instance Convertible LocalDateTime UTCTime where + safeConvert LocalDateTime{..} = Right $ UTCTime julian pico + where julian = Cal.ModifiedJulianDay $ toInteger day + 40587 + (day, pico) = decompLocalBase (_loc_sec_base, toZone _loc_sec_zone) + +instance Convertible LocalDateTimeMillis UTCTime where + safeConvert LocalDateTimeMillis{..} = Right $ UTCTime julian pico + where julian = Cal.ModifiedJulianDay $ toInteger day + 40587 + frac = millis / 1000 + (base, millis) = fmap fromIntegral $ _loc_mil_base `divMod` 0001000 + (day , pico ) = fmap (+ frac) $ decompLocalBase (base, toZone _loc_mil_zone) + +instance Convertible LocalDateTimeMicros UTCTime where + safeConvert LocalDateTimeMicros{..} = Right $ UTCTime julian pico + where julian = Cal.ModifiedJulianDay $ toInteger day + 40587 + frac = micros / 1000000 + (base, micros) = fmap fromIntegral $ _loc_mic_base `divMod` 1000000 + (day , pico ) = fmap (+ frac) $ decompLocalBase (base, toZone _loc_mic_zone) + +instance Convertible LocalDateTimeNanos UTCTime where + safeConvert LocalDateTimeNanos{..} = Right $ UTCTime julian pico + where julian = Cal.ModifiedJulianDay $ toInteger day + 40587 + frac = micros / 1000000 + fromIntegral _loc_nan_nano / 0001000000000 + (base, micros) = fmap fromIntegral $ _loc_nan_base `divMod` 1000000 + (day , pico ) = fmap (+ frac) $ decompLocalBase (base, toZone _loc_nan_zone) + +instance Convertible LocalDateTimePicos UTCTime where + safeConvert LocalDateTimePicos{..} = Right $ UTCTime julian pico + where julian = Cal.ModifiedJulianDay $ toInteger day + 40587 + frac = micros / 1000000 + fromIntegral _loc_pic_pico / 1000000000000 + (base, micros) = fmap fromIntegral $ _loc_pic_base `divMod` 1000000 + (day , pico ) = fmap (+ frac) $ decompLocalBase (base, toZone _loc_pic_zone) + +instance Convertible Cal.Day LocalDate where + safeConvert = Right . check "safeConvert{Data.Time.Calendar.Day,LocalDate}" . + flip LocalDate (fromZone utc) . fromInteger . (subtract 40587) . Cal.toModifiedJulianDay + +instance Convertible UTCTime LocalDateTime where + safeConvert UTCTime{..} = Right . check "safeConvert{Data.Time.Clock.UTCTime,LocalDateTime}" $ + LocalDateTime base (fromZone utc) + where base = baseUnixToUTC $ day * 86400 + truncate utctDayTime + day = fromInteger (Cal.toModifiedJulianDay utctDay) - 40587 + +instance Convertible UTCTime LocalDateTimeMillis where + safeConvert UTCTime{..} = Right . check "safeConvert{Data.Time.Clock.UTCTime,LocalDateTimeMillis}" $ + LocalDateTimeMillis base (fromZone utc) + where base = baseUnixToUTC (day * 86400 + sec) * 0001000 + millis + day = fromInteger (Cal.toModifiedJulianDay utctDay) - 40587 + (sec , millis) = fmap (truncate . (* 0000001000)) $ properFraction utctDayTime + +instance Convertible UTCTime LocalDateTimeMicros where + safeConvert UTCTime{..} = Right . check "safeConvert{Data.Time.Clock.UTCTime,LocalDateTimeMicros}" $ + LocalDateTimeMicros base (fromZone utc) + where base = baseUnixToUTC (day * 86400 + sec) * 1000000 + micros + day = fromInteger (Cal.toModifiedJulianDay utctDay) - 40587 + (sec , micros) = fmap (truncate . (* 0001000000)) $ properFraction utctDayTime + +instance Convertible UTCTime LocalDateTimeNanos where + safeConvert UTCTime{..} = Right . check "safeConvert{Data.Time.Clock.UTCTime,LocalDateTimeNanos}" $ + LocalDateTimeNanos base nano (fromZone utc) + where base = baseUnixToUTC (day * 86400 + sec) * 1000000 + micros + day = fromInteger (Cal.toModifiedJulianDay utctDay) - 40587 + (sec , nanos ) = fmap (truncate . (* 1000000000)) $ properFraction utctDayTime + (nano, micros) = swap . fmap fromIntegral $ divMod nanos 1000 + +instance Convertible UTCTime LocalDateTimePicos where + safeConvert UTCTime{..} = Right . check "safeConvert{Data.Time.Clock.UTCTime,LocalDateTimePicos}" $ + LocalDateTimePicos base pico (fromZone utc) + where base = baseUnixToUTC (day * 86400 + sec) * 1000000 + micros + day = fromInteger (Cal.toModifiedJulianDay utctDay) - 40587 + (sec , picos ) = fmap (truncate . (* 1000000000000)) $ properFraction utctDayTime + (pico, micros) = swap . fmap fromIntegral $ divMod picos 1000000 + +instance DateZone LocalDate where + toDateZoneStruct = decompLocalDate + fromDateZoneStruct DateZoneStruct{..} = + createLocalDate _dz_year _dz_mon _dz_mday _dz_zone + +instance DateZone LocalDateTime where + toDateZoneStruct = decompLocalDate . convert + fromDateZoneStruct DateZoneStruct{..} = + createLocalDateTime _dz_year _dz_mon _dz_mday 0 0 0 _dz_zone + +instance DateZone LocalDateTimeMillis where + toDateZoneStruct = decompLocalDate . convert + fromDateZoneStruct DateZoneStruct{..} = + createLocalDateTimeMillis _dz_year _dz_mon _dz_mday 0 0 0 0 _dz_zone + +instance DateZone LocalDateTimeMicros where + toDateZoneStruct = decompLocalDate . convert + fromDateZoneStruct DateZoneStruct{..} = + createLocalDateTimeMicros _dz_year _dz_mon _dz_mday 0 0 0 0 _dz_zone + +instance DateZone LocalDateTimeNanos where + toDateZoneStruct = decompLocalDate . convert + fromDateZoneStruct DateZoneStruct{..} = + createLocalDateTimeNanos _dz_year _dz_mon _dz_mday 0 0 0 0 _dz_zone + +instance DateZone LocalDateTimePicos where + toDateZoneStruct = decompLocalDate . convert + fromDateZoneStruct DateZoneStruct{..} = + createLocalDateTimePicos _dz_year _dz_mon _dz_mday 0 0 0 0 _dz_zone + +deriving instance DateZone Transition + +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 + +deriving instance DateTimeZone Transition + +instance Show LocalDate where + show date = printf str _dz_year mon _dz_mday abbr + where DateZoneStruct{..} = toDateZoneStruct date + str = "%04d-%02d-%02d %s" + mon = fromEnum _dz_mon + 1 + abbr = show $ abbreviate _dz_zone + +instance Show LocalDateTime where + show time = printf str _dtz_year mon _dtz_mday _dtz_hour _dtz_min sec abbr + where DateTimeZoneStruct{..} = toDateTimeZoneStruct time + str = "%04d-%02d-%02d %02d:%02d:%02d %s" + abbr = show $ abbreviate _dtz_zone + mon = fromEnum _dtz_mon + 1 + sec = round _dtz_sec :: Second + +instance Show LocalDateTimeMillis where + show time = printf str _dtz_year 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 $ abbreviate _dtz_zone + mon = fromEnum _dtz_mon + 1 + (sec, mil) = properFracMillis _dtz_sec + +instance Show LocalDateTimeMicros where + show time = printf str _dtz_year 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 $ abbreviate _dtz_zone + mon = fromEnum _dtz_mon + 1 + (sec, mic) = properFracMicros _dtz_sec + +instance Show LocalDateTimeNanos where + show time = printf str _dtz_year 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 $ abbreviate _dtz_zone + mon = fromEnum _dtz_mon + 1 + (sec, nan) = properFracNanos _dtz_sec + +instance Show LocalDateTimePicos where + show time = printf str _dtz_year 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 $ abbreviate _dtz_zone + mon = fromEnum _dtz_mon + 1 + (sec, pic) = properFracPicos _dtz_sec + +instance Show Transition where + show = show . unboxTrans + +-- | The next leap second insertion date. +nextLeap :: Maybe UnixDate +nextLeap = Nothing + +-- | Get a list of time zone transition times for the given city. +getTransitions :: City -> IO [Transition] +getTransitions city = do + let file = getOlsonFile city + Olson.OlsonData{..} <- Olson.getOlsonFromFile file + let ttimes = uniquetimes $ sortBy future2past olsonTransitions + return $! foldr (step olsonTypes) [] ttimes + where uniquetimes = groupBy $ on (==) Olson.transTime + future2past = comparing $ negate . Olson.transTime + step types ~[Olson.Transition{..}] accum = + if transTime < 0 + then [Transition (LocalDateTime 43200 zone)] + else Transition (LocalDateTime base zone) : accum + where Olson.TtInfo{..} = types !! transIndex + abbr = TimeZoneAbbr city tt_abbr + base = baseUnixToUTC $ fromIntegral transTime + zone = fromZone $ unabbreviate abbr + +-- | Get the current local date from the system clock. +-- +-- > >>> getCurrentLocalDate London +-- > 2013-11-03 GMT +-- +getCurrentLocalDate :: City -> IO LocalDate +getCurrentLocalDate city = getTransitions city >>= getCurrentLocalDateTime' >>= return . convert + +-- | Get the current local date from the system clock using preloaded transition times. +-- +-- > >>> ttimes <- getTransitions Tokyo +-- > >>> getCurrentLocalDate' ttimes +-- > 2013-11-04 JST +-- +-- Use this function if you need to get the current local date more than once. The +-- use of preloaded transition times will avoid unnecessary parsing of Olson files. +getCurrentLocalDate' :: [Transition] -> IO LocalDate +getCurrentLocalDate' ttimes = getCurrentLocalDateTime' ttimes >>= return . convert + +-- | Get the current local date and time from the system clock. +-- +-- > >>> getCurrentLocalDateTime New_York +-- > 2013-11-03 16:38:16 EST +-- +getCurrentLocalDateTime :: City -> IO LocalDateTime +getCurrentLocalDateTime city = getTransitions city >>= getCurrentLocalDateTime' + +-- | Get the current local date and time from the system clock using preloaded transition +-- times. +-- +-- > >>> ttimes <- getTransitions Moscow +-- > >>> getCurrentLocalDateTime' ttimes +-- > 2013-11-04 01:41:50 MSK +-- +-- Use this function if you need to get the current local date and time more than once. +-- The use of preloaded transition times will avoid unnecessary parsing of Olson files. +getCurrentLocalDateTime' :: [Transition] -> IO LocalDateTime +getCurrentLocalDateTime' ttimes = do + time@UnixDateTime{..} <- getCurrentUnixDateTime + let base = baseUnixToUTC _uni_sec_base + f tt = localBase tt > base + mval = listToMaybe $ dropWhile f ttimes + zone = maybe (fromZone utc) localZone mval + if maybe True (/= convert time) nextLeap + then return $! LocalDateTime base zone + else let leap = round (realToFrac (_uni_sec_base `mod` 86400) / 86400 :: Double) + in return $! LocalDateTime base zone `plus` Second leap + +-- | Get the current local date and time with millisecond granularity from the system clock. +-- +-- > >>> getCurrentLocalDateTimeMillis Auckland +-- > 2013-11-04 10:46:13.123 NZDT +-- +getCurrentLocalDateTimeMillis :: City -> IO LocalDateTimeMillis +getCurrentLocalDateTimeMillis city = getTransitions city >>= getCurrentLocalDateTimeMillis' + +-- | Get the current local date and time with millisecond granularity from the system clock +-- using preloaded transition times. +-- +-- > >>> ttimes <- getTransitions Tehran +-- > >>> getCurrentLocalDateTimeMillis' ttimes +-- > 2013-11-04 01:20:49.435 IRST +-- +-- Use this function if you need to get the current local date and time with millisecond +-- granularity more than once. The use of preloaded transition times will avoid unnecessary +-- parsing of Olson files. +getCurrentLocalDateTimeMillis' :: [Transition] -> IO LocalDateTimeMillis +getCurrentLocalDateTimeMillis' ttimes = do + time@UnixDateTimeMillis{..} <- getCurrentUnixDateTimeMillis + let (seconds, millis) = first baseUnixToUTC $ _uni_mil_base `divMod` 1000 + f tt = localBase tt > seconds + mval = listToMaybe $ dropWhile f ttimes + zone = maybe (fromZone utc) localZone mval + base = seconds * 1000 + millis + if maybe True (/= convert time) nextLeap + then return $! LocalDateTimeMillis base zone + else let leap = round (realToFrac (_uni_mil_base `mod` 86400) / 86.4 :: Double) + in return $! LocalDateTimeMillis base zone `plus` Millis leap + +-- | Get the current local date and time with microsecond granularity from the system clock. +-- +-- > >>> getCurrentLocalDateTimeMicros Tel_Aviv +-- > 2013-11-03 23:55:30.935387 IST +-- +getCurrentLocalDateTimeMicros :: City -> IO LocalDateTimeMicros +getCurrentLocalDateTimeMicros city = getTransitions city >>= getCurrentLocalDateTimeMicros' + +-- | Get the current local date and time with microsecond granularity from the system clock +-- using preloaded transition times. +-- +-- > >>> ttimes <- getTransitions Sao_Paulo +-- > >>> getCurrentLocalDateTimeMicros' ttimes +-- > 2013-11-03 19:58:50.405806 BRST +-- +-- Use this function if you need to get the current local date and time with microsecond +-- granularity more than once. The use of preloaded transition times will avoid unnecessary +-- parsing of Olson files. +getCurrentLocalDateTimeMicros' :: [Transition] -> IO LocalDateTimeMicros +getCurrentLocalDateTimeMicros' ttimes = do + time@UnixDateTimeMicros{..} <- getCurrentUnixDateTimeMicros + let (seconds, micros) = first baseUnixToUTC $ _uni_mic_base `divMod` 1000000 + f tt = localBase tt > seconds + mval = listToMaybe $ dropWhile f ttimes + zone = maybe (fromZone utc) localZone mval + base = seconds * 1000000 + micros + if maybe True (/= convert time) nextLeap + then return $! LocalDateTimeMicros base zone + else let leap = round (realToFrac (_uni_mic_base `mod` 86400) / 0.0864 :: Double) + in return $! LocalDateTimeMicros base zone `plus` Micros leap + +-- | Get the current local date and time with nanosecond granularity from the system clock. +-- +-- > >>> getCurrentLocalDateTimeNanos Brussels +-- > 2013-11-03 23:01:07.337488000 CET +-- +-- Note that this functions calls @gettimeofday@ behind the scenes. Therefore, the resultant +-- timestamp will have nanosecond granularity, but only microsecond resolution. +getCurrentLocalDateTimeNanos :: City -> IO LocalDateTimeNanos +getCurrentLocalDateTimeNanos city = getTransitions city >>= getCurrentLocalDateTimeNanos' + +-- | Get the current local date and time with nanosecond granularity from the system clock +-- using preloaded transition times. +-- +-- > >>> ttimes <- getTransitions Mogadishu +-- > >>> getCurrentLocalDateTimeNanos' ttimes +-- > 2013-11-04 01:15:08.664426000 EAT +-- +-- Use this function if you need to get the current local date and time with nanosecond +-- granularity more than once. The use of preloaded transition times will avoid unnecessary +-- parsing of Olson files. +-- +-- Note that this functions calls @gettimeofday@ behind the scenes. Therefore, the resultant +-- timestamp will have nanosecond granularity, but only microsecond resolution. +getCurrentLocalDateTimeNanos' :: [Transition] -> IO LocalDateTimeNanos +getCurrentLocalDateTimeNanos' ttimes = do + time@UnixDateTimeNanos{..} <- getCurrentUnixDateTimeNanos + let (seconds, micros) = first baseUnixToUTC $ _uni_nan_base `divMod` 1000000 + f tt = localBase tt > seconds + mval = listToMaybe $ dropWhile f ttimes + zone = maybe (fromZone utc) localZone mval + base = seconds * 1000000 + micros + if maybe True (/= convert time) nextLeap + then return $! LocalDateTimeNanos base _uni_nan_nano zone + else let leap = round (realToFrac (_uni_nan_base `mod` 86400) / 0.0000864 :: Double) + in return $! LocalDateTimeNanos base _uni_nan_nano zone `plus` Nanos leap + +-- | Get the current local date and time with picosecond granularity from the system clock. +-- +-- > >>> getCurrentLocalDateTimePicos Karachi +-- > 2013-11-04 22:05:17.556043000000 PKT +-- +-- Note that this functions calls @gettimeofday()@ behind the scenes. Therefore, the resultant +-- timestamp will have picosecond granularity, but only microsecond resolution. +getCurrentLocalDateTimePicos :: City -> IO LocalDateTimePicos +getCurrentLocalDateTimePicos city = getTransitions city >>= getCurrentLocalDateTimePicos' + +-- | Get the current local date and time with picosecond granularity from the system clock using +-- preloaded transition times. +-- +-- > >>> ttimes <- getTransitions Baghdad +-- > >>> getCurrentLocalDateTimePicos' ttimes +-- > 2013-11-04 01:20:57.502906000000 AST +-- +-- Use this function if you need to get the current local date and time with picosecond +-- granularity more than once. The use of preloaded transition times will avoid unnecessary +-- parsing of Olson files. +-- +-- Note that this functions calls @gettimeofday()@ behind the scenes. Therefore, the resultant +-- timestamp will have picosecond granularity, but only microsecond resolution. +getCurrentLocalDateTimePicos' :: [Transition] -> IO LocalDateTimePicos +getCurrentLocalDateTimePicos' ttimes = do + time@UnixDateTimePicos{..} <- getCurrentUnixDateTimePicos + let (seconds, micros) = first baseUnixToUTC $ _uni_pic_base `divMod` 1000000 + f tt = localBase tt > seconds + mval = listToMaybe $ dropWhile f ttimes + zone = maybe (fromZone utc) localZone mval + base = seconds * 1000000 + micros + if maybe True (/= convert time) nextLeap + then return $! LocalDateTimePicos base _uni_pic_pico zone + else let picos = round (realToFrac (_uni_pic_base `mod` 86400) / 0.0000000864 :: Double) + in return $! LocalDateTimePicos base _uni_pic_pico zone `plus` Picos picos + +-- | Convert a local date and time with nanosecond granularity into an integer. +fromLocalDateTimeNanos :: LocalDateTimeNanos -> Integer +fromLocalDateTimeNanos (LocalDateTimeNanos base nano _) = toInteger base * 1000 + toInteger nano + +-- | Convert an integer into a local date and time with nanosecond granularity. +toLocalDateTimeNanos :: Integer -> (Word8 -> LocalDateTimeNanos) +toLocalDateTimeNanos n = LocalDateTimeNanos base nano + where (base, nano) = doubleIntegral $ n `divMod` 1000 + +-- | Convert a local date and time with picosecond granularity into an integer. +fromLocalDateTimePicos :: LocalDateTimePicos -> Integer +fromLocalDateTimePicos (LocalDateTimePicos base pico _) = toInteger base * 1000000 + toInteger pico + +-- | Convert an integer into a local date and time with picosecond granularity. +toLocalDateTimePicos :: Integer -> (Word8 -> LocalDateTimePicos) +toLocalDateTimePicos n = LocalDateTimePicos base pico + where (base, pico) = doubleIntegral $ n `divMod` 1000000 + +instance Duration LocalDate Day where + duration (LocalDate old _) (LocalDate new _) = Day (new - old) + +instance Duration LocalDateTime Second where + duration (LocalDateTime old _) (LocalDateTime new _) = Second (new - old) + +instance Duration LocalDateTimeMillis Second where + duration (LocalDateTimeMillis old _ ) (LocalDateTimeMillis new _ ) = Second (new - old) `div` 1000 + +instance Duration LocalDateTimeMicros Second where + duration (LocalDateTimeMicros old _ ) (LocalDateTimeMicros new _ ) = Second (new - old) `div` 1000000 + +instance Duration LocalDateTimeNanos Second where + duration (LocalDateTimeNanos old _ _) (LocalDateTimeNanos new _ _) = Second (new - old) `div` 1000000 + +instance Duration LocalDateTimePicos Second where + duration (LocalDateTimePicos old _ _) (LocalDateTimePicos new _ _) = Second (new - old) `div` 1000000 + +instance Duration LocalDateTimeMillis Millis where + duration (LocalDateTimeMillis old _ ) (LocalDateTimeMillis new _ ) = Millis (new - old) + +instance Duration LocalDateTimeMicros Millis where + duration (LocalDateTimeMicros old _ ) (LocalDateTimeMicros new _ ) = Millis (new - old) `div` 1000 + +instance Duration LocalDateTimeNanos Millis where + duration (LocalDateTimeNanos old _ _) (LocalDateTimeNanos new _ _) = Millis (new - old) `div` 1000 + +instance Duration LocalDateTimePicos Millis where + duration (LocalDateTimePicos old _ _) (LocalDateTimePicos new _ _) = Millis (new - old) `div` 1000 + +instance Duration LocalDateTimeMicros Micros where + duration (LocalDateTimeMicros old _ ) (LocalDateTimeMicros new _ ) = Micros (new - old) + +instance Duration LocalDateTimeNanos Micros where + duration (LocalDateTimeNanos old _ _) (LocalDateTimeNanos new _ _) = Micros (new - old) + +instance Duration LocalDateTimePicos Micros where + duration (LocalDateTimePicos old _ _) (LocalDateTimePicos new _ _) = Micros (new - old) + +instance Duration LocalDateTimeNanos Nanos where + duration old new = + if res < toInteger (maxBound::Int64) then Nanos $ fromInteger res + else error "duration{LocalDateTimeNanos,Nanos}: integer overflow" + where res = fromLocalDateTimeNanos new - fromLocalDateTimeNanos old + +instance Duration LocalDateTimePicos Nanos where + duration old new = + if res < toInteger (maxBound::Int64) then Nanos $ fromInteger res + else error "duration{LocalDateTimePicos,Nanos}: integer overflow" + where res = fromLocalDateTimePicos new - fromLocalDateTimePicos old + +instance Duration LocalDateTimePicos Picos where + duration old new = + if res < toInteger (maxBound::Int64) then Picos $ fromInteger res + else error "duration{LocalDateTimePicos,Picos}: integer overflow" + where res = fromLocalDateTimePicos new - fromLocalDateTimePicos old + +instance Random LocalDate where + random g = + case randomR (0,2932896) g of { (base, g' ) -> + case randomR (0,maxZone) g' of { (zone, g'') -> (LocalDate base zone, g'') } } + randomR (a,b) g = + case randomR (get loc_day_base a, get loc_day_base b) g of { (base, g' ) -> + case randomR (get loc_day_zone a, get 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 ( 0, maxZone) g' of { (zone, g'') -> (LocalDateTime base zone, g'') } } + randomR (a,b) g = + case randomR (get loc_sec_base a, get loc_sec_base b) g of { (base, g' ) -> + case randomR (get loc_sec_zone a, get loc_sec_zone b) g' of { (zone, g'') -> (LocalDateTime base zone, g'') } } + +instance Random LocalDateTimeMillis where + random g = + case randomR (43200,253402257624999) g of { (base, g' ) -> + case randomR ( 0, maxZone) g' of { (zone, g'') -> (LocalDateTimeMillis base zone, g'') } } + randomR (a,b) g = + case randomR (get loc_mil_base a, get loc_mil_base b) g of { (base, g' ) -> + case randomR (get loc_mil_zone a, get loc_mil_zone b) g' of { (zone, g'') -> (LocalDateTimeMillis base zone, g'') } } + +instance Random LocalDateTimeMicros where + random g = + case randomR (43200,253402257624999999) g of { (base, g' ) -> + case randomR ( 0, maxZone) g' of { (zone, g'') -> (LocalDateTimeMicros base zone, g'') } } + randomR (a,b) g = + case randomR (get loc_mic_base a, get loc_mic_base b) g of { (base, g' ) -> + case randomR (get loc_mic_zone a, get loc_mic_zone b) g' of { (zone, g'') -> (LocalDateTimeMicros base zone, g'') } } + +instance Random LocalDateTimeNanos where + random g = + case randomR (43200,253402257624999999999) g of { (base, g' ) -> + case randomR ( 0, maxZone) g' of { (zone, g'') -> (toLocalDateTimeNanos base zone, g'') } } + randomR (a,b) g = + case randomR (fromLocalDateTimeNanos a, fromLocalDateTimeNanos b) g of { (base, g' ) -> + case randomR ( get loc_nan_zone a, get loc_nan_zone b) g' of { (zone, g'') -> (toLocalDateTimeNanos base zone, g'') } } + +instance Random LocalDateTimePicos where + random g = + case randomR (43200,253402257624999999999999) g of { (base, g' ) -> + case randomR ( 0, maxZone) g' of { (zone, g'') -> (toLocalDateTimePicos base zone, g'') } } + randomR (a,b) g = + case randomR (fromLocalDateTimePicos a, fromLocalDateTimePicos b) g of { (base, g' ) -> + case randomR ( get loc_pic_zone a, get loc_pic_zone b) g' of { (zone, g'') -> (toLocalDateTimePicos base zone, g'') } } + +deriving instance Random Transition + +-- | Show a local date as a pretty string. +-- +-- > >>> prettyLocalDate $ createLocalDate 2014 September 25 Japan_Standard_Time +-- > "Thursday, September 25th, 2014 (JST)" +-- +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 = show _dz_mon + mday = show _dz_mday ++ showSuffix _dz_mday + abbr = show $ abbreviate _dz_zone + +-- | Show a local date and time as a pretty string. +-- +-- > >>> getCurrentLocalDateTime Los_Angeles >>= return . prettyLocalDateTime +-- > "2:17 AM, Wednesday, January 1st, 2014 (PST)" +-- +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 = show _dtz_mon + mday = show _dtz_mday ++ showSuffix _dtz_mday + abbr = show $ abbreviate _dtz_zone + ampm = showPeriod _dtz_hour + hour | _dtz_hour == 00 = 12 + | _dtz_hour <= 12 = _dtz_hour + | otherwise = _dtz_hour - 12 + +instance Zone LocalDate where + rezone time = flip (set loc_day_zone) time . fromZone + +instance Zone LocalDateTime where + rezone time = flip (set loc_sec_zone) time . fromZone + +instance Zone LocalDateTimeMillis where + rezone time = flip (set loc_mil_zone) time . fromZone + +instance Zone LocalDateTimeMicros where + rezone time = flip (set loc_mic_zone) time . fromZone + +instance Zone LocalDateTimeNanos where + rezone time = flip (set loc_nan_zone) time . fromZone + +instance Zone LocalDateTimePicos where + rezone time = flip (set loc_pic_zone) time . fromZone + +-- | Maximum enumerated time zone value. +maxZone :: Word8 +maxZone = fromZone maxBound + +-- | Convert an integral type into a time zone. +toZone :: Word8 -> TimeZone +toZone = toEnum . fromIntegral + +-- | Convert a time zone into a numeric value. +fromZone :: TimeZone -> Word8 +fromZone = fromIntegral . fromEnum + +-- | Perform a bounds check on the given local timestamp. +check :: forall a . Bounded a => Local a => Ord a => String -> a -> a +check f x = + if minBound <= x && x <= maxBound then x + else error $ f ++ ": base (" ++ base ++ ") out of bounds (" ++ bounds ++ ")" + where base = show (localBase x) + bounds = show (localBase (minBound::a)) ++ "," ++ show (localBase (maxBound::a)) + +-- | Coerce a tuple of integral types. +doubleIntegral :: (Integral a, Integral b, Num c, Num d) => (a, b) -> (c, d) +doubleIntegral = fromIntegral *** fromIntegral diff --git a/src/Data/Time/Exts/Test.hs b/src/Data/Time/Exts/Test.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Exts/Test.hs @@ -0,0 +1,149 @@ +--------------------------------------------------------------- +-- Copyright (c) 2013, Enzo Haussecker. All rights reserved. -- +--------------------------------------------------------------- + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wall #-} +{-# OPTIONS -fno-warn-orphans #-} + +module Main where + +import Data.Convertible +import Data.Time.Calendar as Calendar +import Data.Time.Clock +import Data.Time.Exts +import Foreign.C.Types +import Test.QuickCheck + +instance Arbitrary City where + arbitrary = choose (minBound, maxBound) + +instance Arbitrary TimeZone where + arbitrary = choose (minBound, maxBound) + +instance Arbitrary UnixDate where + arbitrary = choose (minBound, maxBound) + +instance Arbitrary UnixDateTime where + arbitrary = choose (minBound, maxBound) + +instance Arbitrary UnixDateTimeMillis where + arbitrary = choose (minBound, maxBound) + +instance Arbitrary UnixDateTimeMicros where + arbitrary = choose (minBound, maxBound) + +instance Arbitrary UnixDateTimeNanos where + arbitrary = choose (minBound, maxBound) + +instance Arbitrary UnixDateTimePicos where + arbitrary = choose (minBound, maxBound) + +instance Arbitrary LocalDate where + arbitrary = choose (minBound, maxBound) + +instance Arbitrary LocalDateTime where + arbitrary = choose (minBound, maxBound) + +instance Arbitrary LocalDateTimeMillis where + arbitrary = choose (minBound, maxBound) + +instance Arbitrary LocalDateTimeMicros where + arbitrary = choose (minBound, maxBound) + +instance Arbitrary LocalDateTimeNanos where + arbitrary = choose (minBound, maxBound) + +instance Arbitrary LocalDateTimePicos where + arbitrary = choose (minBound, maxBound) + +-- | Test Unix date and time component equality. +test1 :: (Bounded x, DateTime x, Duration x Second, Show x, Unix x) => x -> Bool +test1 x + -- Testing year equality... + | toInteger (c'tm'tm_year + 1900) /= + toInteger ( _dt_year ) = unequal + -- Testing month equality... + | toInteger ( c'tm'tm_mon + 1) /= + toInteger (fromEnum _dt_mon + 1) = unequal + -- Testing day of month equality... + | toInteger c'tm'tm_mday /= + toInteger _dt_mday = unequal + -- Testing day of week equality... + | toInteger ( c'tm'tm_wday) /= + toInteger (fromEnum _dt_wday) = unequal + -- Testing hour equality... + | toInteger c'tm'tm_hour /= + toInteger _dt_hour = unequal + -- Testing minute equality... + | toInteger c'tm'tm_min /= + toInteger _dt_min = unequal + -- Testing second equality... + | toInteger c'tm'tm_sec /= + truncate _dt_sec = unequal + -- Success! + | otherwise = True + where Second base = duration minBound x + DateTimeStruct{..} = toDateTimeStruct x + C'tm{..} = convert $ CTime base + unequal = error $ "test1: " ++ show x + +-- | Test Unix date struct conversions. +test2 :: (Eq x, Date x, Show x, Unix x) => x -> Bool +test2 x | x == fromDateStruct (toDateStruct x) = True + | otherwise = error $ "test2: " ++ show x + +-- | Test Unix date-time struct conversions. +test3 :: (Eq x, DateTime x, Show x, Unix x) => x -> Bool +test3 x | x == fromDateTimeStruct (toDateTimeStruct x) = True + | otherwise = error $ "test3: " ++ show x + +-- | Test local date struct conversions. +test4 :: (Eq x, DateZone x, Local x, Show x) => x -> Bool +test4 x | x == fromDateZoneStruct (toDateZoneStruct x) = True + | otherwise = error $ "test4: " ++ show x + +-- | Test local date-time struct conversions. +test5 :: (Eq x, DateTimeZone x, Local x, Show x) => x -> Bool +test5 x | x == fromDateTimeZoneStruct (toDateTimeZoneStruct x) = True + | otherwise = error $ "test5: " ++ show x + +-- | Test calendar day conversions. +test6 :: (Convertible x Calendar.Day, Convertible Calendar.Day x, Eq x, Show x, Zone x) => x -> Bool +test6 x | x' == convert (convert x' :: Calendar.Day) = True + | otherwise = error $ "test6: " ++ show x' + where x' = rezone x utc + +-- | Test utc time conversions. +test7 :: (Convertible x UTCTime, Convertible UTCTime x, Eq x, Show x, Zone x) => x -> Bool +test7 x | x' == convert (convert x' :: UTCTime) = True + | otherwise = error $ "test7: " ++ show x' + where x' = rezone x utc + +-- | Test properties. +main :: IO () +main = do + quickCheck (test1 :: UnixDateTime -> Bool) + quickCheck (test1 :: UnixDateTimeMillis -> Bool) + quickCheck (test1 :: UnixDateTimeMicros -> Bool) + quickCheck (test1 :: UnixDateTimeNanos -> Bool) + quickCheck (test1 :: UnixDateTimePicos -> Bool) + quickCheck (test2 :: UnixDate -> Bool) + quickCheck (test3 :: UnixDateTime -> Bool) + quickCheck (test3 :: UnixDateTimeMillis -> Bool) + quickCheck (test3 :: UnixDateTimeMicros -> Bool) + quickCheck (test3 :: UnixDateTimeNanos -> Bool) + quickCheck (test3 :: UnixDateTimePicos -> Bool) + quickCheck (test4 :: LocalDate -> Bool) + quickCheck (test5 :: LocalDateTime -> Bool) + quickCheck (test5 :: LocalDateTimeMillis -> Bool) + quickCheck (test5 :: LocalDateTimeMicros -> Bool) + quickCheck (test5 :: LocalDateTimeNanos -> Bool) + quickCheck (test5 :: LocalDateTimePicos -> Bool) + quickCheck (test6 :: LocalDate -> Bool) + quickCheck (test7 :: LocalDateTime -> Bool) + quickCheck (test7 :: LocalDateTimeMillis -> Bool) + quickCheck (test7 :: LocalDateTimeMicros -> Bool) + quickCheck (test7 :: LocalDateTimeNanos -> Bool) + quickCheck (test7 :: LocalDateTimePicos -> Bool) diff --git a/src/Data/Time/Exts/Unix.hs b/src/Data/Time/Exts/Unix.hs --- a/src/Data/Time/Exts/Unix.hs +++ b/src/Data/Time/Exts/Unix.hs @@ -1,887 +1,875 @@ --------------------------------------------------------------- --- 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" - --- | Types and functions for Unix timestamps. -module Data.Time.Exts.Unix ( - - -- * Unix Class - Unix - - -- * Unix Timestamps - , UnixDate(..) - , UnixDateTime(..) - , UnixDateTimeMillis(..) - , UnixDateTimeMicros(..) - , UnixDateTimeNanos(..) - , UnixDateTimePicos(..) - - -- * Create Unix Timestamps - , createUnixDate - , createUnixDateTime - , createUnixDateTimeMillis - , createUnixDateTimeMicros - , createUnixDateTimeNanos - , createUnixDateTimePicos - - -- * Get Current Unix Timestamps - , getCurrentUnixDate - , getCurrentUnixDateTime - , getCurrentUnixDateTimeMillis - , getCurrentUnixDateTimeMicros - , getCurrentUnixDateTimeNanos - , getCurrentUnixDateTimePicos - - ) 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) - --- | A class of Unix timestamps. -class Unix x - --- | A Unix date. -newtype UnixDate = UnixDate Int32 - deriving (Eq,FromJSON,Generic,Integral,NFData,Num,Ord,Random,Real,Storable,ToJSON,Typeable) - --- | A Unix date and time. -newtype UnixDateTime = UnixDateTime Int64 - deriving (Eq,FromJSON,Generic,Integral,NFData,Num,Ord,Random,Real,Storable,ToJSON,Typeable) - --- | A Unix date and time with millisecond granularity. -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) - --- | A Unix date and time with microsecond granularity. -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) - --- | A Unix date and time with nanosecond granularity. -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) - --- | A Unix date and time with picosecond granularity. -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 - --- | Create a Unix date. --- --- > >>> createUnixDate 2013 11 03 --- > 2013-11-03 --- -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 - --- | Create a Unix date and time. --- --- > >>> createUnixDateTime 2013 11 03 22 58 29 --- > 2013-11-03 22:58:29 --- -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 - --- | Create a Unix date and time with millisecond granularity. --- --- > >>> createUnixDateTimeMillis 2013 11 03 22 59 13 922 --- > 2013-11-03 22:59:13.922 --- -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 - --- | Create a Unix date and time with microsecond granularity. --- --- > >>> createUnixDateTimeMicros 2013 11 03 23 00 13 573166 --- > 2013-11-03 23:00:13.573166 --- -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 - --- | Create a Unix date and time with nanosecond granularity. --- --- > >>> createUnixDateTimeNanos 2013 11 03 23 01 43 946387023 --- > 2013-11-03 23:01:43.946387023 --- -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 - --- | Create a Unix date and time with picosecond granularity. --- --- > >>> createUnixDateTimePicos 2013 11 03 23 04 35 816235224967 --- > 2013-11-03 23:04:35.816235224967 --- -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 - --- | Decompose 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 - --- | Decompose the number of days since January 1st into month and day components. -decompYearToDate :: Day -> Bool -> (Month, Day) -decompYearToDate days leap = - if leap - then if days >= 182 - then if days >= 274 - then if days >= 335 - then (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) - --- | Compute the day of the week from the given Unix date. -dayOfWeek :: UnixDate -> DayOfWeek -dayOfWeek date = - case date `mod` 7 of - 0 -> Thursday - 1 -> Friday - 2 -> Saturday - 3 -> Sunday - 4 -> Monday - 5 -> Tuesday - _ -> Wednesday - --- | Decompose 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 - --- | Decompose 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 - --- | Decompose 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 - --- | Decompose 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 - --- | Decompose 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 - --- | Get the current Unix date from the system clock. --- --- > >>> getCurrentUnixDate --- > 2013-11-03 --- -getCurrentUnixDate :: IO UnixDate -getCurrentUnixDate = getCurrentUnixDateTime >>= return . convert - --- | Get the current Unix date and time from the system clock. --- --- > >>> getCurrentUnixDateTime --- > 2013-11-03 23:09:38 --- -getCurrentUnixDateTime :: IO UnixDateTime -getCurrentUnixDateTime = - with (TimeOfDay 0 0) $ \ ptr -> - getTimeOfDay ptr nullPtr >>= getResult ptr - where getResult ptr 0 = peek $ castPtr ptr - getResult _ _ = error "getCurrentUnixDateTime: unknown" - --- | Get the current Unix date and time with millisecond granularity from the system clock. --- --- > >>> getCurrentUnixDateTimeMillis --- > 2013-11-03 23:09:51.986 --- -getCurrentUnixDateTimeMillis :: IO UnixDateTimeMillis -getCurrentUnixDateTimeMillis = - with (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" - --- | Get the current Unix date and time with microsecond granularity from the system clock. --- --- > >>> getCurrentUnixDateTimeMicros --- > 2013-11-03 23:10:06.498559 --- -getCurrentUnixDateTimeMicros :: IO UnixDateTimeMicros -getCurrentUnixDateTimeMicros = - with (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" - --- | Get the current Unix date and time with nanosecond granularity from the system clock. --- --- > >>> getCurrentUnixDateTimeNanos --- > 2013-11-03 23:10:23.697893000 --- --- Note that this functions calls @gettimeofday()@ behind the scenes. Therefore, the resultant --- timestamp will have nanosecond granularity, but only microsecond resolution. -getCurrentUnixDateTimeNanos :: IO UnixDateTimeNanos -getCurrentUnixDateTimeNanos = - with (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" - --- | Get the current Unix date and time with picosecond granularity from the system clock. --- --- > >>> getCurrentUnixDateTimePicos --- > 2013-11-03 23:10:44.633032000000 --- --- Note that this functions calls @gettimeofday()@ behind the scenes. Therefore, the resultant --- timestamp will have picosecond granularity, but only microsecond resolution. -getCurrentUnixDateTimePicos :: IO UnixDateTimePicos -getCurrentUnixDateTimePicos = - with (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" - --- | Show 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 - --- | Show 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 +-- Copyright (c) 2014, Enzo Haussecker. All rights reserved. -- +--------------------------------------------------------------- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS -Wall #-} + +-- | Unix timestamps of varying granularity. +module Data.Time.Exts.Unix ( + + -- ** Unix Class + Unix(..) + + -- ** Unix Timestamps + , UnixDate(..) + , UnixDateTime(..) + , UnixDateTimeMillis(..) + , UnixDateTimeMicros(..) + , UnixDateTimeNanos(..) + , UnixDateTimePicos(..) + + -- ** Create Unix Timestamps + , createUnixDate + , createUnixDateTime + , createUnixDateTimeMillis + , createUnixDateTimeMicros + , createUnixDateTimeNanos + , createUnixDateTimePicos + + -- ** Get Current Unix Timestamps + , getCurrentUnixDate + , getCurrentUnixDateTime + , getCurrentUnixDateTimeMillis + , getCurrentUnixDateTimeMicros + , getCurrentUnixDateTimeNanos + , getCurrentUnixDateTimePicos + + -- ** Pretty Unix Timestamps + , prettyUnixDate + , prettyUnixDateTime + + ) where + +import Control.Arrow ((***), first) +import Control.DeepSeq (NFData) +import Data.Aeson (FromJSON, ToJSON) +import Data.Convertible (Convertible(..), convert) +import Data.Int (Int16, Int32, Int64) +import Data.Label (get, mkLabels, modify) +import Data.Time.Exts.Base +import Data.Time.Exts.C +import Data.Typeable (Typeable) +import Foreign.C.Types (CLong(..)) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (castPtr, nullPtr, plusPtr) +import Foreign.Storable (Storable(..)) +import GHC.Generics (Generic) +import System.Random (Random(..)) +import Text.Printf (printf) + +-- | The Unix timestamp type class. +class Unix u where + + -- | Get the base component of a Unix timestamp. + unixBase :: u -> Int64 + +-- | Days since Unix epoch. +newtype UnixDate = UnixDate { + _uni_day_base :: Int32 + } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable) + +-- | Seconds since Unix epoch (excluding leap seconds). +newtype UnixDateTime = UnixDateTime { + _uni_sec_base :: Int64 + } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable) + +-- | Milliseconds since Unix epoch (excluding leap seconds). +newtype UnixDateTimeMillis = UnixDateTimeMillis { + _uni_mil_base :: Int64 + } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable) + +-- | Microseconds since Unix epoch (excluding leap seconds). +newtype UnixDateTimeMicros = UnixDateTimeMicros { + _uni_mic_base :: Int64 + } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable) + +-- | Nanoseconds since Unix epoch (excluding leap seconds). +data UnixDateTimeNanos = UnixDateTimeNanos { + _uni_nan_base :: {-# UNPACK #-} !Int64 + , _uni_nan_nano :: {-# UNPACK #-} !Int16 + } deriving (Eq,Generic,Ord,Typeable) + +-- | Picoseconds since Unix epoch (excluding leap seconds). +data UnixDateTimePicos = UnixDateTimePicos { + _uni_pic_base :: {-# UNPACK #-} !Int64 + , _uni_pic_pico :: {-# UNPACK #-} !Int32 + } deriving (Eq,Generic,Ord,Typeable) + +instance FromJSON UnixDateTimeNanos +instance FromJSON UnixDateTimePicos + +instance NFData UnixDateTimeNanos +instance NFData UnixDateTimePicos + +instance Storable UnixDateTimeNanos where + sizeOf _ = 10 + alignment = sizeOf + peekElemOff ptr n = do + let off = 10 * n + base <- peek . plusPtr ptr $ off + nano <- peek . plusPtr ptr $ off + 8 + return $! UnixDateTimeNanos base nano + pokeElemOff ptr n UnixDateTimeNanos{..} = do + let off = 10 * n + poke (plusPtr ptr $ off ) _uni_nan_base + poke (plusPtr ptr $ off + 8) _uni_nan_nano + +instance Storable UnixDateTimePicos where + sizeOf _ = 12 + alignment = sizeOf + peekElemOff ptr n = do + let off = 12 * n + base <- peek . plusPtr ptr $ off + pico <- peek . plusPtr ptr $ off + 8 + return $! UnixDateTimePicos base pico + pokeElemOff ptr n UnixDateTimePicos{..} = do + let off = 12 * n + poke (plusPtr ptr $ off ) _uni_pic_base + poke (plusPtr ptr $ off + 8) _uni_pic_pico + +instance ToJSON UnixDateTimeNanos +instance ToJSON UnixDateTimePicos + +mkLabels [ ''DateTimeStruct + , ''UnixDate + , ''UnixDateTime + , ''UnixDateTimeMillis + , ''UnixDateTimeMicros + , ''UnixDateTimeNanos + , ''UnixDateTimePicos + ] + +instance Bounded UnixDate where + minBound = UnixDate 0 + maxBound = UnixDate 2932896 + +instance Bounded UnixDateTime where + minBound = UnixDateTime 0 + maxBound = UnixDateTime 253402300799 + +instance Bounded UnixDateTimeMillis where + minBound = UnixDateTimeMillis 0 + maxBound = UnixDateTimeMillis 253402300799999 + +instance Bounded UnixDateTimeMicros where + minBound = UnixDateTimeMicros 0 + maxBound = UnixDateTimeMicros 253402300799999999 + +instance Bounded UnixDateTimeNanos where + minBound = UnixDateTimeNanos 0 0 + maxBound = UnixDateTimeNanos 253402300799999999 999 + +instance Bounded UnixDateTimePicos where + minBound = UnixDateTimePicos 0 0 + maxBound = UnixDateTimePicos 253402300799999999 999999 + +instance Unix UnixDate where + unixBase = fromIntegral . get uni_day_base + +instance Unix UnixDateTime where + unixBase = get uni_sec_base + +instance Unix UnixDateTimeMillis where + unixBase = get uni_mil_base + +instance Unix UnixDateTimeMicros where + unixBase = get uni_mic_base + +instance Unix UnixDateTimeNanos where + unixBase = get uni_nan_base + +instance Unix UnixDateTimePicos where + unixBase = get uni_pic_base + +instance DateTimeMath UnixDate Day where + date `plus` Day day = + check "plus{UnixDate,Day}" $ + modify uni_day_base (+ day) date + +instance DateTimeMath UnixDateTime Day where + time `plus` Day day = + check "plus{UnixDateTime,Day}" $ + modify uni_sec_base (+ fromIntegral day * 86400) time + +instance DateTimeMath UnixDateTimeMillis Day where + time `plus` Day day = + check "plus{UnixDateTimeMillis,Day}" $ + modify uni_mil_base (+ fromIntegral day * 86400000) time + +instance DateTimeMath UnixDateTimeMicros Day where + time `plus` Day day = + check "plus{UnixDateTimeMicros,Day}" $ + modify uni_mic_base (+ fromIntegral day * 86400000000) time + +instance DateTimeMath UnixDateTimeNanos Day where + time `plus` Day day = + check "plus{UnixDateTimeNanos,Day}" $ + modify uni_nan_base (+ fromIntegral day * 86400000000) time + +instance DateTimeMath UnixDateTimePicos Day where + time `plus` Day day = + check "plus{UnixDateTimePicos,Day}" $ + modify uni_pic_base (+ fromIntegral day * 86400000000) time + +instance DateTimeMath UnixDateTime Hour where + time `plus` Hour hour = + check "plus{UnixDateTime,Hour}" $ + modify uni_sec_base (+ hour * 3600) time + +instance DateTimeMath UnixDateTimeMillis Hour where + time `plus` Hour hour = + check "plus{UnixDateTimeMillis,Hour}" $ + modify uni_mil_base (+ hour * 3600000) time + +instance DateTimeMath UnixDateTimeMicros Hour where + time `plus` Hour hour = + check "plus{UnixDateTimeMicros,Hour}" $ + modify uni_mic_base (+ hour * 3600000000) time + +instance DateTimeMath UnixDateTimeNanos Hour where + time `plus` Hour hour = + check "plus{UnixDateTimeNanos,Hour}" $ + modify uni_nan_base (+ hour * 3600000000) time + +instance DateTimeMath UnixDateTimePicos Hour where + time `plus` Hour hour = + check "plus{UnixDateTimePicos,Hour}" $ + modify uni_pic_base (+ hour * 3600000000) time + +instance DateTimeMath UnixDateTime Minute where + time `plus` Minute minute = + check "plus{UnixDateTime,Minute}" $ + modify uni_sec_base (+ minute * 60) time + +instance DateTimeMath UnixDateTimeMillis Minute where + time `plus` Minute minute = + check "plus{UnixDateTimeMillis,Minute}" $ + modify uni_mil_base (+ minute * 60000) time + +instance DateTimeMath UnixDateTimeMicros Minute where + time `plus` Minute minute = + check "plus{UnixDateTimeMicros,Minute}" $ + modify uni_mic_base (+ minute * 60000000) time + +instance DateTimeMath UnixDateTimeNanos Minute where + time `plus` Minute minute = + check "plus{UnixDateTimeNanos,Minute}" $ + modify uni_nan_base (+ minute * 60000000) time + +instance DateTimeMath UnixDateTimePicos Minute where + time `plus` Minute minute = + check "plus{UnixDateTimePicos,Minute}" $ + modify uni_pic_base (+ minute * 60000000) time + +instance DateTimeMath UnixDateTime Second where + time `plus` Second second = + check "plus{UnixDateTime,Second}" $ + modify uni_sec_base (+ second) time + +instance DateTimeMath UnixDateTimeMillis Second where + time `plus` Second second = + check "plus{UnixDateTimeMillis,Second}" $ + modify uni_mil_base (+ second * 1000) time + +instance DateTimeMath UnixDateTimeMicros Second where + time `plus` Second second = + check "plus{UnixDateTimeMicros,Second}" $ + modify uni_mic_base (+ second * 1000000) time + +instance DateTimeMath UnixDateTimeNanos Second where + time `plus` Second second = + check "plus{UnixDateTimeNanos,Second}" $ + modify uni_nan_base (+ second * 1000000) time + +instance DateTimeMath UnixDateTimePicos Second where + time `plus` Second second = + check "plus{UnixDateTimePicos,Second}" $ + modify uni_pic_base (+ second * 1000000) time + +instance DateTimeMath UnixDateTimeMillis Millis where + time `plus` Millis millis = + check "plus{UnixDateTimeMillis,Millis}" $ + modify uni_mil_base (+ millis) time + +instance DateTimeMath UnixDateTimeMicros Millis where + time `plus` Millis millis = + check "plus{UnixDateTimeMicros,Millis}" $ + modify uni_mic_base (+ millis * 1000) time + +instance DateTimeMath UnixDateTimeNanos Millis where + time `plus` Millis millis = + check "plus{UnixDateTimeNanos,Millis}" $ + modify uni_nan_base (+ millis * 1000) time + +instance DateTimeMath UnixDateTimePicos Millis where + time `plus` Millis millis = + check "plus{UnixDateTimePicos,Millis}" $ + modify uni_pic_base (+ millis * 1000) time + +instance DateTimeMath UnixDateTimeMicros Micros where + time `plus` Micros micros = + check "plus{UnixDateTimeMicros,Micros}" $ + modify uni_mic_base (+ micros) time + +instance DateTimeMath UnixDateTimeNanos Micros where + time `plus` Micros micros = + check "plus{UnixDateTimeNanos,Micros}" $ + modify uni_nan_base (+ micros) time + +instance DateTimeMath UnixDateTimePicos Micros where + time `plus` Micros micros = + check "plus{UnixDateTimePicos,Micros}" $ + modify uni_pic_base (+ micros) time + +instance DateTimeMath UnixDateTimeNanos Nanos where + UnixDateTimeNanos{..} `plus` Nanos nanos = + check "plus{UnixDateTimeNanos,Nanos}" . + uncurry UnixDateTimeNanos . + both (+ _uni_nan_base) fromIntegral . + flip divMod 1000 $ + fromIntegral _uni_nan_nano + nanos + +instance DateTimeMath UnixDateTimePicos Nanos where + UnixDateTimePicos{..} `plus` Nanos nanos = + check "plus{UnixDateTimePicos,Nanos}" . + uncurry UnixDateTimePicos . + both (+ _uni_pic_base) fromIntegral . + flip divMod 1000000 $ + fromIntegral _uni_pic_pico + nanos * 1000 + +instance DateTimeMath UnixDateTimePicos Picos where + UnixDateTimePicos{..} `plus` Picos picos = + check "plus{UnixDateTimePicos,Picos}" . + uncurry UnixDateTimePicos . + both (+ _uni_pic_base) fromIntegral . + flip divMod 1000000 $ + fromIntegral _uni_pic_pico + picos + +instance Enum UnixDate where + succ = flip plus $ Day 1 + pred = flip plus . Day $ - 1 + toEnum = check "toEnum{UnixDate}" . UnixDate . fromIntegral + fromEnum = fromIntegral . _uni_day_base + +instance Enum UnixDateTime where + succ = flip plus $ Second 1 + pred = flip plus . Second $ - 1 + toEnum = check "toEnum{UnixDateTime}" . UnixDateTime . fromIntegral + fromEnum = fromIntegral . _uni_sec_base + +instance Enum UnixDateTimeMillis where + succ = flip plus $ Millis 1 + pred = flip plus . Millis $ - 1 + toEnum = check "toEnum{UnixDateTimeMillis}" . UnixDateTimeMillis . fromIntegral + fromEnum = fromIntegral . _uni_mil_base + +instance Enum UnixDateTimeMicros where + succ = flip plus $ Micros 1 + pred = flip plus . Micros $ - 1 + toEnum = check "toEnum{UnixDateTimeMicros}" . UnixDateTimeMicros . fromIntegral + fromEnum = fromIntegral . _uni_mic_base + +-- | Create a Unix date. +-- +-- > >>> createUnixDate 2013 November 03 +-- > 2013-11-03 +-- +createUnixDate :: Year -> Month -> Day -> UnixDate +createUnixDate year month day = + check "createUnixDate" $ UnixDate base + where Day base = epochToDate year month day + +-- | Create a Unix date and time. +-- +-- > >>> createUnixDateTime 2012 April 27 07 37 30 +-- > 2012-04-27 07:37:30 +-- +createUnixDateTime :: Year -> Month -> Day -> Hour -> Minute -> Second -> UnixDateTime +createUnixDateTime year month day hour minute second = + check "createUnixDateTime" $ UnixDateTime base + where Second base = epochToTime year month day hour minute second + +-- | Create a Unix date and time with millisecond granularity. +-- +-- > >>> createUnixDateTimeMillis 2014 February 02 08 52 37 983 +-- > 2014-02-02 08:52:37.983 +-- +createUnixDateTimeMillis :: Year -> Month -> Day -> Hour -> Minute -> Second -> Millis -> UnixDateTimeMillis +createUnixDateTimeMillis year month day hour minute second (Millis millis) = + check "createUnixDateTimeMillis" $ UnixDateTimeMillis base + where Second seconds = epochToTime year month day hour minute second + base = seconds * 1000 + millis + +-- | Create a Unix date and time with microsecond granularity. +-- +-- > >>> createUnixDateTimeMicros 2011 January 22 17 34 13 138563 +-- > 2011-01-22 17:34:13.138563 +-- +createUnixDateTimeMicros :: Year -> Month -> Day -> Hour -> Minute -> Second -> Micros -> UnixDateTimeMicros +createUnixDateTimeMicros year month day hour minute second (Micros micros) = + check "createUnixDateTimeMicros" $ UnixDateTimeMicros base + where Second seconds = epochToTime year month day hour minute second + base = seconds * 1000000 + micros + +-- | Create a Unix date and time with nanosecond granularity. +-- +-- > >>> createUnixDateTimeNanos 2012 June 28 01 30 35 688279651 +-- > 2012-06-28 01:30:35.688279651 +-- +createUnixDateTimeNanos :: Year -> Month -> Day -> Hour -> Minute -> Second -> Nanos -> UnixDateTimeNanos +createUnixDateTimeNanos year month day hour minute second (Nanos nanos) = + check "createUnixDateTimeNanos" $ UnixDateTimeNanos base nano + where (micros, nano) = fmap fromIntegral $ divMod nanos 1000 + Second seconds = epochToTime year month day hour minute second + base = seconds * 1000000 + micros + +-- | Create a Unix date and time with picosecond granularity. +-- +-- > >>> createUnixDateTimePicos 2014 August 02 10 57 54 809479393286 +-- > 2014-08-02 10:57:54.809479393286 +-- +createUnixDateTimePicos :: Year -> Month -> Day -> Hour -> Minute -> Second -> Picos -> UnixDateTimePicos +createUnixDateTimePicos year month day hour minute second (Picos picos) = + check "createUnixDateTimePicos" $ UnixDateTimePicos base pico + where (micros, pico) = fmap fromIntegral $ divMod picos 1000000 + Second seconds = epochToTime year month day hour minute second + base = seconds * 1000000 + micros + +-- | Decompose the number of days since +-- January 1st into month and day components. +decompYearToDate :: Day -> Bool -> (Month, Day) +decompYearToDate days leap = + if leap + then if days >= 182 + then if days >= 274 + then if days >= 335 + then (December, days - 334) + else if days >= 305 + then (November, days - 304) + else (October , days - 273) + else if days >= 244 + then (September, days - 243) + else if days >= 213 + then (August, days - 212) + else (July , days - 181) + else if days >= 091 + then if days >= 152 + then (June, days - 151) + else if days >= 121 + then (May , days - 120) + else (April, days - 090) + else if days >= 060 + then (March, days - 059) + else if days >= 031 + then (February, days - 030) + else (January , days + 001) + else if days >= 181 + then if days >= 273 + then if days >= 334 + then (December, days - 333) + else if days >= 304 + then (November, days - 303) + else (October , days - 272) + else if days >= 243 + then (September, days - 242) + else if days >= 212 + then (August, days - 211) + else (July , days - 180) + else if days >= 090 + then if days >= 151 + then (June, days - 150) + else if days >= 120 + then (May , days - 119) + else (April, days - 089) + else if days >= 059 + then (March, days - 058) + else if days >= 031 + then (February, days - 030) + else (January , days + 001) + +-- | Decompose a Unix date into a human-readable format. +decompUnixDate :: UnixDate -> DateStruct +decompUnixDate (UnixDate base) = + go 1970 $ Day base + where go :: Year -> Day -> DateStruct + go !year !days = + if days >= size + then go (year + 1) (days - size) + else DateStruct year month mday wday + where wday = toEnum $ (fromIntegral base + 4) `mod` 7 + leap = isLeapYear year + size = if leap then 366 else 365 + (month, mday) = decompYearToDate days leap + +-- | Decompose a Unix date and time into a human-readable format. +decompUnixDateTime :: UnixDateTime -> DateTimeStruct +decompUnixDateTime (UnixDateTime base) = + DateTimeStruct _d_year _d_mon _d_mday _d_wday hour mn sec + where DateStruct{..} = decompUnixDate $ UnixDate date + (date, mod1) = both fromIntegral Hour $ divMod base 86400 + (hour, mod2) = fmap fromIntegral $ divMod mod1 03600 + (mn , sec ) = fmap realToFrac $ divMod mod2 00060 + +-- | Decompose a Unix date and time with millisecond granularity into a human-readable format. +decompUnixDateTimeMillis :: UnixDateTimeMillis -> DateTimeStruct +decompUnixDateTimeMillis (UnixDateTimeMillis base) = + DateTimeStruct _d_year _d_mon _d_mday _d_wday hour mn $ sec + mill / 0001000 + where DateStruct{..} = decompUnixDate $ UnixDate date + (date, mod1) = both fromIntegral Hour $ divMod base 86400000 + (hour, mod2) = fmap fromIntegral $ divMod mod1 03600000 + (mn , mod3) = divMod mod2 00060000 + (sec , mill) = both realToFrac realToFrac $ divMod mod3 00001000 + +-- | Decompose a Unix date and time with microsecond granularity into a human-readable format. +decompUnixDateTimeMicros :: UnixDateTimeMicros -> DateTimeStruct +decompUnixDateTimeMicros (UnixDateTimeMicros base) = + DateTimeStruct _d_year _d_mon _d_mday _d_wday hour mn $ sec + micr / 1000000 + where DateStruct{..} = decompUnixDate $ UnixDate date + (date, mod1) = both fromIntegral Hour $ divMod base 86400000000 + (hour, mod2) = fmap fromIntegral $ divMod mod1 03600000000 + (mn , mod3) = divMod mod2 00060000000 + (sec , micr) = both realToFrac realToFrac $ divMod mod3 00001000000 + +-- | Decompose a Unix date and time with nanosecond granularity into a human-readable format. +decompUnixDateTimeNanos :: UnixDateTimeNanos -> DateTimeStruct +decompUnixDateTimeNanos (UnixDateTimeNanos base nano) = + modify dt_sec (+ fromIntegral nano / 0001000000000) . decompUnixDateTimeMicros $ UnixDateTimeMicros base + +-- | Decompose a Unix date and time with picosecond granularity into a human-readable format. +decompUnixDateTimePicos :: UnixDateTimePicos -> DateTimeStruct +decompUnixDateTimePicos (UnixDateTimePicos base pico) = + modify dt_sec (+ fromIntegral pico / 1000000000000) . decompUnixDateTimeMicros $ UnixDateTimeMicros base + +instance Convertible UnixDateTime UnixDate where + safeConvert = Right . UnixDate . fromIntegral . flip div 00000086400 . _uni_sec_base + +instance Convertible UnixDateTimeMillis UnixDate where + safeConvert = Right . UnixDate . fromIntegral . flip div 00086400000 . _uni_mil_base + +instance Convertible UnixDateTimeMicros UnixDate where + safeConvert = Right . UnixDate . fromIntegral . flip div 86400000000 . _uni_mic_base + +instance Convertible UnixDateTimeNanos UnixDate where + safeConvert = Right . UnixDate . fromIntegral . flip div 86400000000 . _uni_nan_base + +instance Convertible UnixDateTimePicos UnixDate where + safeConvert = Right . UnixDate . fromIntegral . flip div 86400000000 . _uni_pic_base + +instance Date UnixDate where + toDateStruct = decompUnixDate + fromDateStruct DateStruct{..} = + createUnixDate _d_year _d_mon _d_mday + +instance Date UnixDateTime where + toDateStruct = decompUnixDate . convert + fromDateStruct DateStruct{..} = + createUnixDateTime _d_year _d_mon _d_mday 0 0 0 + +instance Date UnixDateTimeMillis where + toDateStruct = decompUnixDate . convert + fromDateStruct DateStruct{..} = + createUnixDateTimeMillis _d_year _d_mon _d_mday 0 0 0 0 + +instance Date UnixDateTimeMicros where + toDateStruct = decompUnixDate . convert + fromDateStruct DateStruct{..} = + createUnixDateTimeMicros _d_year _d_mon _d_mday 0 0 0 0 + +instance Date UnixDateTimeNanos where + toDateStruct = decompUnixDate . convert + fromDateStruct DateStruct{..} = + createUnixDateTimeNanos _d_year _d_mon _d_mday 0 0 0 0 + +instance Date UnixDateTimePicos where + toDateStruct = decompUnixDate . convert + fromDateStruct DateStruct{..} = + createUnixDateTimePicos _d_year _d_mon _d_mday 0 0 0 0 + +instance DateTime UnixDateTime where + toDateTimeStruct = decompUnixDateTime + fromDateTimeStruct DateTimeStruct{..} = + createUnixDateTime _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec + where sec = round _dt_sec :: Second + +instance DateTime UnixDateTimeMillis where + toDateTimeStruct = decompUnixDateTimeMillis + fromDateTimeStruct DateTimeStruct{..} = + createUnixDateTimeMillis _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec mil + where (sec, mil) = properFracMillis _dt_sec + +instance DateTime UnixDateTimeMicros where + toDateTimeStruct = decompUnixDateTimeMicros + fromDateTimeStruct DateTimeStruct{..} = + createUnixDateTimeMicros _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec mic + where (sec, mic) = properFracMicros _dt_sec + +instance DateTime UnixDateTimeNanos where + toDateTimeStruct = decompUnixDateTimeNanos + fromDateTimeStruct DateTimeStruct{..} = + createUnixDateTimeNanos _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec nan + where (sec, nan) = properFracNanos _dt_sec + +instance DateTime UnixDateTimePicos where + toDateTimeStruct = decompUnixDateTimePicos + fromDateTimeStruct DateTimeStruct{..} = + createUnixDateTimePicos _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec pic + where (sec, pic) = properFracPicos _dt_sec + +instance Show UnixDate where + show date = printf "%04d-%02d-%02d" _d_year mon _d_mday + where DateStruct{..} = toDateStruct date + mon = fromEnum _d_mon + 1 + +instance Show UnixDateTime where + show time = printf "%04d-%02d-%02d %02d:%02d:%02d" _dt_year mon _dt_mday _dt_hour _dt_min sec + where DateTimeStruct{..} = toDateTimeStruct time + mon = fromEnum _dt_mon + 1 + sec = round _dt_sec :: Second + +instance Show UnixDateTimeMillis where + show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%03d" _dt_year mon _dt_mday _dt_hour _dt_min sec mill + where DateTimeStruct{..} = toDateTimeStruct time + mon = fromEnum _dt_mon + 1 + (sec, mill) = properFracMillis _dt_sec + +instance Show UnixDateTimeMicros where + show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%06d" _dt_year mon _dt_mday _dt_hour _dt_min sec micr + where DateTimeStruct{..} = toDateTimeStruct time + mon = fromEnum _dt_mon + 1 + (sec, micr) = properFracMicros _dt_sec + +instance Show UnixDateTimeNanos where + show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%09d" _dt_year mon _dt_mday _dt_hour _dt_min sec nano + where DateTimeStruct{..} = toDateTimeStruct time + mon = fromEnum _dt_mon + 1 + (sec, nano) = properFracNanos _dt_sec + +instance Show UnixDateTimePicos where + show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%012d" _dt_year mon _dt_mday _dt_hour _dt_min sec pico + where DateTimeStruct{..} = toDateTimeStruct time + mon = fromEnum _dt_mon + 1 + (sec, pico) = properFracPicos _dt_sec + +-- | Get the current Unix date from the system clock. +-- +-- > >>> getCurrentUnixDate +-- > 2013-11-03 +-- +getCurrentUnixDate :: IO UnixDate +getCurrentUnixDate = getCurrentUnixDateTime >>= return . convert + +-- | Get the current Unix date and time from the system clock. +-- +-- > >>> getCurrentUnixDateTime +-- > 2013-11-03 23:09:38 +-- +getCurrentUnixDateTime :: IO UnixDateTime +getCurrentUnixDateTime = + with (C'timeval 0 0) $ \ ptr -> + c'gettimeofday ptr nullPtr >>= getResult ptr + where getResult ptr 0 = peek $ castPtr ptr + getResult _ _ = error "getCurrentUnixDateTime: unknown" + +-- | Get the current Unix date and time with millisecond granularity from the system clock. +-- +-- > >>> getCurrentUnixDateTimeMillis +-- > 2013-11-03 23:09:51.986 +-- +getCurrentUnixDateTimeMillis :: IO UnixDateTimeMillis +getCurrentUnixDateTimeMillis = + with (C'timeval 0 0) $ \ ptr -> + c'gettimeofday ptr nullPtr >>= getResult ptr + where getResult ptr 0 = peek ptr >>= \ (C'timeval (CLong base) (CLong micr)) -> + return $! UnixDateTimeMillis $ base * 1000 + micr `div` 1000 + getResult _ _ = error "getCurrentUnixDateTimeMillis: unknown" + +-- | Get the current Unix date and time with microsecond granularity from the system clock. +-- +-- > >>> getCurrentUnixDateTimeMicros +-- > 2013-11-03 23:10:06.498559 +-- +getCurrentUnixDateTimeMicros :: IO UnixDateTimeMicros +getCurrentUnixDateTimeMicros = + with (C'timeval 0 0) $ \ ptr -> + c'gettimeofday ptr nullPtr >>= getResult ptr + where getResult ptr 0 = peek ptr >>= \ (C'timeval (CLong base) (CLong micr)) -> + return $! UnixDateTimeMicros $ base * 1000000 + micr + getResult _ _ = error "getCurrentUnixDateTimeMicros: unknown" + +-- | Get the current Unix date and time with nanosecond granularity from the system clock. +-- +-- > >>> getCurrentUnixDateTimeNanos +-- > 2013-11-03 23:10:23.697893000 +-- +-- Note that this functions calls @gettimeofday@ behind the scenes. Therefore, the resultant +-- timestamp will have nanosecond granularity, but only microsecond resolution. +getCurrentUnixDateTimeNanos :: IO UnixDateTimeNanos +getCurrentUnixDateTimeNanos = + with (C'timeval 0 0) $ \ ptr -> + c'gettimeofday ptr nullPtr >>= getResult ptr + where getResult ptr 0 = peek ptr >>= \ (C'timeval (CLong base) (CLong micr)) -> + return $! UnixDateTimeNanos (base * 1000000 + micr) 0 + getResult _ _ = error "getCurrentUnixDateTimeNanos: unknown" + +-- | Get the current Unix date and time with picosecond granularity from the system clock. +-- +-- > >>> getCurrentUnixDateTimePicos +-- > 2013-11-03 23:10:44.633032000000 +-- +-- Note that this functions calls @gettimeofday@ behind the scenes. Therefore, the resultant +-- timestamp will have picosecond granularity, but only microsecond resolution. +getCurrentUnixDateTimePicos :: IO UnixDateTimePicos +getCurrentUnixDateTimePicos = + with (C'timeval 0 0) $ \ ptr -> + c'gettimeofday ptr nullPtr >>= getResult ptr + where getResult ptr 0 = peek ptr >>= \ (C'timeval (CLong base) (CLong micr)) -> + return $! UnixDateTimePicos (base * 1000000 + micr) 0 + getResult _ _ = error "getCurrentUnixDateTimePicos: unknown" + +-- | Convert a Unix date and time with nanosecond granularity into an integer. +fromNano :: UnixDateTimeNanos -> Integer +fromNano (UnixDateTimeNanos base nano) = toInteger base * 0001000 + toInteger nano + +-- | Convert a Unix date and time with picosecond granularity into an integer. +fromPico :: UnixDateTimePicos -> Integer +fromPico (UnixDateTimePicos base pico) = toInteger base * 1000000 + toInteger pico + +-- | Convert an integer into a Unix date and time with nanosecond granularity. +toNano :: Integer -> UnixDateTimeNanos +toNano = uncurry UnixDateTimeNanos . both fromInteger fromInteger . flip divMod 1000 + +-- | Convert an integer into a Unix date and time with picosecond granularity. +toPico :: Integer -> UnixDateTimePicos +toPico = uncurry UnixDateTimePicos . both fromInteger fromInteger . flip divMod 1000000 + +instance Duration UnixDate Day where + duration (UnixDate old) (UnixDate new) = Day (new - old) + +instance Duration UnixDateTime Second where + duration (UnixDateTime old) (UnixDateTime new) = Second (new - old) + +instance Duration UnixDateTimeMillis Second where + duration (UnixDateTimeMillis old ) (UnixDateTimeMillis new ) = Second (new - old) `div` 1000 + +instance Duration UnixDateTimeMicros Second where + duration (UnixDateTimeMicros old ) (UnixDateTimeMicros new ) = Second (new - old) `div` 1000000 + +instance Duration UnixDateTimeNanos Second where + duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = Second (new - old) `div` 1000000 + +instance Duration UnixDateTimePicos Second where + duration (UnixDateTimePicos old _) (UnixDateTimePicos new _) = Second (new - old) `div` 1000000 + +instance Duration UnixDateTimeMillis Millis where + duration (UnixDateTimeMillis old ) (UnixDateTimeMillis new ) = Millis (new - old) + +instance Duration UnixDateTimeMicros Millis where + duration (UnixDateTimeMicros old ) (UnixDateTimeMicros new ) = Millis (new - old) `div` 1000 + +instance Duration UnixDateTimeNanos Millis where + duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = Millis (new - old) `div` 1000 + +instance Duration UnixDateTimePicos Millis where + duration (UnixDateTimePicos old _) (UnixDateTimePicos new _) = Millis (new - old) `div` 1000 + +instance Duration UnixDateTimeMicros Micros where + duration (UnixDateTimeMicros old ) (UnixDateTimeMicros new ) = Micros (new - old) + +instance Duration UnixDateTimeNanos Micros where + duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = Micros (new - old) + +instance Duration UnixDateTimePicos Micros where + duration (UnixDateTimePicos old _) (UnixDateTimePicos new _) = Micros (new - old) + +instance Duration UnixDateTimeNanos Nanos where + duration old new = + if res < toInteger (maxBound::Int64) then Nanos $ fromInteger res + else error "duration{UnixDateTimeNanos,Nanos}: integer overflow" + where res = fromNano new - fromNano old + +instance Duration UnixDateTimePicos Nanos where + duration old new = + if res < toInteger (maxBound::Int64) then Nanos $ fromInteger res + else error "duration{UnixDateTimePicos,Nanos}: integer overflow" + where res = fromPico new - fromPico old + +instance Duration UnixDateTimePicos Picos where + duration old new = + if res < toInteger (maxBound::Int64) then Picos $ fromInteger res + else error "duration{UnixDateTimePicos,Picos}: integer overflow" + where res = fromPico new - fromPico old + +instance Random UnixDate where + random = first toEnum . randomR (0,000000000000000002932896) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + +instance Random UnixDateTime where + random = first toEnum . randomR (0,000000000000253402300799) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + +instance Random UnixDateTimeMillis where + random = first toEnum . randomR (0,000000000253402300799999) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + +instance Random UnixDateTimeMicros where + random = first toEnum . randomR (0,000000253402300799999999) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + +instance Random UnixDateTimeNanos where + random = first toNano . randomR (0,000253402300799999999999) + randomR (a,b) = first toNano . randomR (fromNano a, fromNano b) + +instance Random UnixDateTimePicos where + random = first toPico . randomR (0,253402300799999999999999) + randomR (a,b) = first toPico . randomR (fromPico a, fromPico b) + +-- | Show a Unix date as a pretty string. +-- +-- > >>> prettyUnixDate $ createUnixDate 2014 August 16 +-- > "Saturday, August 16th, 2014" +-- +prettyUnixDate :: (Unix d, Date d) => d -> String +prettyUnixDate date = + printf "%s, %s %s, %04d" wday mon mday _d_year + where DateStruct{..} = toDateStruct date + wday = show _d_wday + mon = show _d_mon + mday = show _d_mday ++ showSuffix _d_mday + +-- | Show a Unix date and time as a pretty string. +-- +-- > >>> getCurrentUnixDateTime >>= return . prettyUnixDateTime +-- > "6:44 AM, Tuesday, December 31st, 2013" +-- +prettyUnixDateTime :: (Unix dt, DateTime dt) => dt -> String +prettyUnixDateTime time = + printf str hour _dt_min ampm wday mon mday _dt_year + where DateTimeStruct{..} = toDateTimeStruct time + str = "%d:%02d %s, %s, %s %s, %04d" + wday = show _dt_wday + mon = show _dt_mon + mday = show _dt_mday ++ showSuffix _dt_mday + ampm = showPeriod _dt_hour + hour | _dt_hour == 00 = 12 + | _dt_hour <= 12 = _dt_hour + | otherwise = _dt_hour - 12 + +-- | Perform a bounds check on the given Unix timestamp. +check :: forall a . Bounded a => Ord a => Unix a => String -> a -> a +check f x = + if minBound <= x && x <= maxBound then x + else error $ f ++ ": base (" ++ base ++ ") out of bounds (" ++ bounds ++ ")" + where base = show (unixBase x) + bounds = show (unixBase (minBound::a)) ++ "," ++ show (unixBase (maxBound::a)) + +-- | A convenient synonym. +both :: forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d) +both = (***) diff --git a/src/Data/Time/Exts/Zone.hs b/src/Data/Time/Exts/Zone.hs --- a/src/Data/Time/Exts/Zone.hs +++ b/src/Data/Time/Exts/Zone.hs @@ -1,36 +1,42 @@ --------------------------------------------------------------- --- Copyright (c) 2013, Enzo Haussecker. All rights reserved. -- +-- Copyright (c) 2014, Enzo Haussecker. All rights reserved. -- --------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS -Wall #-} {-# OPTIONS -fno-warn-type-defaults #-} +-- | Location and time zone constructors and functions. module Data.Time.Exts.Zone ( - -- * Locations + -- ** Locations City(..) , cities + + -- ** Olson Database , getOlsonFile + , olsonFiles - -- * Time Zones + -- ** Time Zones , TimeZone(..) - , getOffset + , utc + , getUTCOffset + , utcOffsets - -- * Abbreviations + -- ** Abbreviations , TimeZoneAbbr(..) + , abbreviate + , unabbreviate + , abbreviations ) where import Control.Arrow (first) import Data.Aeson (FromJSON, ToJSON) -import Data.Convertible (Convertible(..)) -import Data.Ord (comparing) +import Data.Map.Strict (Map, (!), fromDistinctAscList) import Data.Typeable (Typeable) import GHC.Generics (Generic) import System.Random (Random(..)) @@ -84,11 +90,137 @@ | Tirana -- ^ Republic of Albania | Tokyo -- ^ Japan | Toronto -- ^ Canada - | Universal -- ^ Tnternational Territory + | Universal -- ^ International Territory | Vienna -- ^ Republic of Austria | Zurich -- ^ Swiss Confederation - deriving (Eq,Enum,Generic,Ord,Show,Typeable) + deriving (Eq,Enum,Generic,Ord,Read,Show,Typeable) +instance Bounded City where + minBound = Aden + maxBound = Zurich + +instance FromJSON City + +instance Random City where + random = first toEnum . randomR (fromEnum (minBound::City), fromEnum (maxBound::City)) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) + +instance ToJSON City + +-- | 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 + ] + +-- | Get the Olson file associated with the given city. +getOlsonFile :: City -> FilePath +getOlsonFile = (!) olsonFiles + +-- | A map from cities to Olson file paths. +olsonFiles :: Map City FilePath +olsonFiles = fromDistinctAscList + [ (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") + , (Kolkata,"/usr/share/zoneinfo/Asia/Kolkata") + , (Kuwait_City,"/usr/share/zoneinfo/Asia/Kuwait") + , (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") + ] + -- | Time zones from around the world. data TimeZone = Afghanistan_Time @@ -143,324 +275,220 @@ | South_Africa_Standard_Time | West_Africa_Time | Yukon_Standard_Time - deriving (Eq,Enum,Generic,Show,Typeable) - --- | A time zone abbreviation. -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 + deriving (Eq,Enum,Generic,Ord,Read,Show,Typeable) 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 FromJSON TimeZone -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 Random TimeZone where + random = first toEnum . randomR (fromEnum (minBound::TimeZone), fromEnum (maxBound::TimeZone)) + randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) -instance FromJSON City -instance FromJSON TimeZone -instance FromJSON TimeZoneAbbr +instance ToJSON TimeZone -instance Ord TimeZone where - compare = comparing getOffset +-- | The UTC time zone. +utc :: TimeZone +utc = Coordinated_Universal_Time -instance Random City where - random = first toEnum . randomR (0, 49) - randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) +-- | Get the UTC offset (in minutes) for the given time zone. +getUTCOffset :: Num a => TimeZone -> a +getUTCOffset = (!) utcOffsets -instance Random TimeZone where - random = first toEnum . randomR (0, 51) - randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) +-- | A map from time zones to UTC offsets (in minutes). +utcOffsets :: Num a => Map TimeZone a +utcOffsets = fromDistinctAscList + [ (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,60) + , (Central_Africa_Time,120) + , (Central_Daylight_Time,-300) + , (Central_European_Summer_Time,120) + , (Central_European_Time,60) + , (Central_Standard_Time,-360) + , (China_Daylight_Time,540) + , (China_Standard_Time,480) + , (Coordinated_Universal_Time,0) + , (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,0) + , (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,60) + , (Yukon_Standard_Time,-540) + ] +-- | A time zone abbreviation. +data TimeZoneAbbr = TimeZoneAbbr { + abbr_city :: City -- ^ reference location + , abbr_str :: String -- ^ time zone abbreviation string + } deriving (Eq,Generic,Typeable) + +instance FromJSON TimeZoneAbbr + 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 - ] +-- | Abbreviate a time zone. +abbreviate :: TimeZone -> TimeZoneAbbr +abbreviate = (!) abbreviations --- | Get 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" +-- | Unabbreviate a time zone. +unabbreviate :: TimeZoneAbbr -> TimeZone +unabbreviate 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 ++ "'" --- | Get the UTC offset (in minutes) for the given time zone. -getOffset :: Num a => TimeZone -> a -getOffset = \ 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 +-- | A map from time zones to time zone abbreviations. +abbreviations :: Map TimeZone TimeZoneAbbr +abbreviations = fromDistinctAscList + [ (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_Summer_Time,TimeZoneAbbr Hong_Kong "HKST") + , (Hong_Kong_Time,TimeZoneAbbr Hong_Kong "HKT") + , (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") + ] diff --git a/time-exts.cabal b/time-exts.cabal --- a/time-exts.cabal +++ b/time-exts.cabal @@ -1,11 +1,11 @@ Name: time-exts -Version: 1.0.2 +Version: 1.1.0 License: BSD3 License-File: LICENSE -Copyright: Copyright (c) 2013, Enzo Haussecker. All rights reserved. -Author: Enzo Haussecker -Maintainer: Enzo Haussecker -Stability: Stable +Copyright: Copyright (c) 2014, Enzo Haussecker. All rights reserved. +Author: Enzo Haussecker +Maintainer: Enzo Haussecker +Stability: Experimental Category: Time Synopsis: Efficient Timestamps Homepage: https://github.com/enzoh/time-exts @@ -26,11 +26,30 @@ Build-Depends: aeson, base >= 4 && < 5, bindings-DSL, + containers, convertible, deepseq, fclabels, + QuickCheck, random, time, timezone-olson Build-Tools: hsc2hs - GHC-Options: -rtsopts + +Executable test-time-exts + Default-Language: Haskell2010 + HS-Source-Dirs: src + Main-Is: Data/Time/Exts/Test.hs + Other-Modules: Data.Time.Exts.C + Build-Depends: aeson, + base >= 4 && < 5, + bindings-DSL, + containers, + convertible, + deepseq, + fclabels, + QuickCheck, + random, + time, + timezone-olson + Build-Tools: hsc2hs