time-exts 1.0.2 → 1.1.0
raw patch · 9 files changed
+2872/−2535 lines, 9 filesdep +QuickCheckdep +containersnew-component:exe:test-time-exts
Dependencies added: QuickCheck, containers
Files
- LICENSE +1/−1
- src/Data/Time/Exts.hs +15/−3
- src/Data/Time/Exts/Base.hs +183/−181
- src/Data/Time/Exts/C.hsc +3/−3
- src/Data/Time/Exts/Local.hs +1280/−1141
- src/Data/Time/Exts/Test.hs +149/−0
- src/Data/Time/Exts/Unix.hs +874/−886
- src/Data/Time/Exts/Zone.hs +342/−314
- time-exts.cabal +25/−6
LICENSE view
@@ -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:
src/Data/Time/Exts.hs view
@@ -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
src/Data/Time/Exts/Base.hs view
@@ -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"
src/Data/Time/Exts/C.hsc view
@@ -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
src/Data/Time/Exts/Local.hs view
@@ -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
+ src/Data/Time/Exts/Test.hs view
@@ -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)
src/Data/Time/Exts/Unix.hs view
@@ -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 = (***)
src/Data/Time/Exts/Zone.hs view
@@ -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")+ ]
time-exts.cabal view
@@ -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 <enzo@ucsd.edu>-Maintainer: Enzo Haussecker <enzo@ucsd.edu>-Stability: Stable+Copyright: Copyright (c) 2014, Enzo Haussecker. All rights reserved.+Author: Enzo Haussecker <ehaussecker@gmail.com>+Maintainer: Enzo Haussecker <ehaussecker@gmail.com>+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