time-exts 2.1.0 → 3.0.0
raw patch · 23 files changed
+2613/−4788 lines, 23 filesdep +HUnitdep +ieee754dep +lens-simpledep −aesondep −containersdep −convertibledep ~base
Dependencies added: HUnit, ieee754, lens-simple, tz
Dependencies removed: aeson, containers, convertible, data-default, fclabels, timezone-olson
Dependency ranges changed: base
Files
- .travis.yml +10/−0
- Data/Time/Exts.hs +29/−0
- Data/Time/Exts/Base.hs +398/−0
- Data/Time/Exts/Format.hs +48/−0
- Data/Time/Exts/Lens.hs +24/−0
- Data/Time/Exts/Parser.hs +347/−0
- Data/Time/Exts/UTC.hs +442/−0
- Data/Time/Exts/Unix.hs +642/−0
- Data/Time/Exts/Util.hs +116/−0
- Foreign/C/Time.hsc +76/−0
- LICENSE +1/−1
- README.org +2/−0
- Test.hs +404/−0
- src/Data/Time/Exts.hs +0/−35
- src/Data/Time/Exts/Base.hs +0/−366
- src/Data/Time/Exts/C.hsc +0/−58
- src/Data/Time/Exts/Local.hs +0/−1283
- src/Data/Time/Exts/Parser.hs +0/−770
- src/Data/Time/Exts/Test.hs +0/−175
- src/Data/Time/Exts/Unix.hs +0/−1534
- src/Data/Time/Exts/Zone.hs +0/−502
- stack.yaml +4/−0
- time-exts.cabal +70/−64
+ .travis.yml view
@@ -0,0 +1,10 @@+dist: trusty+install:+- travis_retry sudo apt-key adv --keyserver keyserver.ubuntu.com --recv-keys 575159689BEFB442+- travis_retry echo 'deb https://download.fpcomplete.com/ubuntu trusty main' | sudo tee /etc/apt/sources.list.d/fpco.list+- travis_retry sudo apt-get update -y+- travis_retry sudo apt-get install stack -y+script:+- stack setup+- stack build+- stack test
+ Data/Time/Exts.hs view
@@ -0,0 +1,29 @@+-- |+-- Module : Data.Time.Exts+-- Copyright : 2013-2016 Enzo Haussecker+-- License : BSD3+-- Maintainer : Enzo Haussecker <enzo@sovereign.io>+-- Stability : Stable+--+-- A stand-alone time library implementing Unix and UTC timestamps with varying granularity.++module Data.Time.Exts (++ -- * Basic Definitions+ module Data.Time.Exts.Base++ -- * Format Text+ , module Data.Time.Exts.Format++ -- * Coordinated Universal Time+ , module Data.Time.Exts.UTC++ -- * Unix Time+ , module Data.Time.Exts.Unix++ ) where++import Data.Time.Exts.Base+import Data.Time.Exts.Format+import Data.Time.Exts.UTC+import Data.Time.Exts.Unix
+ Data/Time/Exts/Base.hs view
@@ -0,0 +1,398 @@+-- |+-- Module : Data.Time.Exts.Base+-- Copyright : 2013-2016 Enzo Haussecker+-- License : BSD3+-- Maintainer : Enzo Haussecker <enzo@sovereign.io>+-- Stability : Stable+--+-- Basic definitions, including type classes, data types and type families.++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Time.Exts.Base (++ -- * Classes+ Human(..)+ , Math(..)++ -- * Chronologies+ , Calendar(..)+ , Epoch(..)+ , Era++ -- * Components+ , Year(..)+ , Month(..)+ , Day(..)+ , DayOfWeek(..)+ , Hour(..)+ , Minute(..)+ , Second(..)+ , Millis(..)+ , Micros(..)+ , Nanos(..)+ , Picos(..)++ -- * Structs+ , DateStruct(..)+ , TimeStruct(..)+ , DateTimeStruct(..)+ , LocalDateStruct(..)+ , LocalTimeStruct(..)+ , LocalDateTimeStruct(..)++ -- * Fractions+ , properFracMillis+ , properFracMicros+ , properFracNanos+ , properFracPicos++ ) where++import Control.DeepSeq (NFData(..))+import Data.Data (Data, Typeable)+import Data.Int (Int32, Int64)+import Data.Time (TimeZone)+import GHC.Generics (Generic)+import Text.Printf (PrintfArg)++class Human x where++ -- |+ -- Define the human-readable components of a timestamp.+ type Components x :: *++ -- |+ -- Pack a timestamp from human-readable components.+ pack :: Components x -> x++ -- |+ -- Unpack a timestamp to human-readable components.+ unpack :: x -> Components x++class Math x c where++ -- |+ -- Calculate the duration between two timestamps.+ duration :: x -> x -> c++ -- |+ -- Add a duration to a timestamp.+ plus :: x -> c -> x++-- |+-- System for organizing dates.+data Calendar =+ Chinese+ | Gregorian+ | Hebrew+ | Islamic+ | Julian+ deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++instance NFData Calendar++-- |+-- System origin.+data Epoch =+ Unix+ deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++instance NFData Epoch++-- |+-- System for numbering years.+data family Era (cal :: Calendar) :: *++data instance Era 'Gregorian =+ BeforeChrist+ | AnnoDomini+ deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++instance NFData (Era 'Gregorian)++-- |+-- Year.+newtype Year = Year {getYear :: Int32}+ deriving (Bounded, Data, Enum, Eq, Generic, Integral, NFData, Num, Ord, PrintfArg, Read, Real, Typeable)++instance Show Year where+ show Year {..} = show getYear++-- |+-- Month.+data family Month (cal :: Calendar) :: *++data instance Month 'Gregorian =+ January+ | February+ | March+ | April+ | May+ | June+ | July+ | August+ | September+ | October+ | November+ | December+ deriving (Bounded, Data, Eq, Generic, Ord, Read, Show, Typeable)++instance Enum (Month 'Gregorian) where++ fromEnum January = 01+ fromEnum February = 02+ fromEnum March = 03+ fromEnum April = 04+ fromEnum May = 05+ fromEnum June = 06+ fromEnum July = 07+ fromEnum August = 08+ fromEnum September = 09+ fromEnum October = 10+ fromEnum November = 11+ fromEnum December = 12++ toEnum 01 = January+ toEnum 02 = February+ toEnum 03 = March+ toEnum 04 = April+ toEnum 05 = May+ toEnum 06 = June+ toEnum 07 = July+ toEnum 08 = August+ toEnum 09 = September+ toEnum 10 = October+ toEnum 11 = November+ toEnum 12 = December+ toEnum __ = error "toEnum{Month 'Gregorian}: out of range"++instance NFData (Month 'Gregorian)++-- |+-- Day.+newtype Day = Day {getDay :: Int32}+ deriving (Bounded, Data, Enum, Eq, Generic, Integral, NFData, Num, Ord, PrintfArg, Read, Real, Typeable)++instance Show Day where+ show Day {..} = show getDay++-- |+-- Day of week.+data family DayOfWeek (cal :: Calendar) :: *++data instance DayOfWeek 'Gregorian =+ Sunday+ | Monday+ | Tuesday+ | Wednesday+ | Thursday+ | Friday+ | Saturday+ deriving (Bounded, Data, Eq, Generic, Ord, Read, Show, Typeable)++instance Enum (DayOfWeek 'Gregorian) where++ fromEnum Sunday = 1+ fromEnum Monday = 2+ fromEnum Tuesday = 3+ fromEnum Wednesday = 4+ fromEnum Thursday = 5+ fromEnum Friday = 6+ fromEnum Saturday = 7++ toEnum 1 = Sunday+ toEnum 2 = Monday+ toEnum 3 = Tuesday+ toEnum 4 = Wednesday+ toEnum 5 = Thursday+ toEnum 6 = Friday+ toEnum 7 = Saturday+ toEnum _ = error "toEnum{DayOfWeek 'Gregorian}: out of range"++instance NFData (DayOfWeek 'Gregorian)++-- |+-- Hour.+newtype Hour = Hour {getHour :: Int64}+ deriving (Bounded, Data, Enum, Eq, Generic, Integral, NFData, Num, Ord, PrintfArg, Read, Real, Typeable)++instance Show Hour where+ show Hour {..} = show getHour++-- |+-- Minute.+newtype Minute = Minute {getMinute :: Int64}+ deriving (Bounded, Data, Enum, Eq, Generic, Integral, NFData, Num, Ord, PrintfArg, Read, Real, Typeable)++instance Show Minute where+ show Minute {..} = show getMinute++-- |+-- Second.+newtype Second = Second {getSecond :: Int64}+ deriving (Bounded, Data, Enum, Eq, Generic, Integral, NFData, Num, Ord, PrintfArg, Read, Real, Typeable)++instance Show Second where+ show Second {..} = show getSecond++-- |+-- Millisecond.+newtype Millis = Millis {getMillis :: Int64}+ deriving (Bounded, Data, Enum, Eq, Generic, Integral, NFData, Num, Ord, PrintfArg, Read, Real, Typeable)++instance Show Millis where+ show Millis {..} = show getMillis++-- |+-- Microsecond.+newtype Micros = Micros {getMicros :: Int64}+ deriving (Bounded, Data, Enum, Eq, Generic, Integral, NFData, Num, Ord, PrintfArg, Read, Real, Typeable)++instance Show Micros where+ show Micros {..} = show getMicros++-- |+-- Nanosecond.+newtype Nanos = Nanos {getNanos :: Int64}+ deriving (Bounded, Data, Enum, Eq, Generic, Integral, NFData, Num, Ord, PrintfArg, Read, Real, Typeable)++instance Show Nanos where+ show Nanos {..} = show getNanos++-- |+-- Picosecond.+newtype Picos = Picos {getPicos :: Int64}+ deriving (Bounded, Data, Enum, Eq, Generic, Integral, NFData, Num, Ord, PrintfArg, Read, Real, Typeable)++instance Show Picos where+ show Picos {..} = show getPicos++-- |+-- A struct with date components.+data DateStruct (cal :: Calendar) =+ DateStruct+ { _d_year :: {-# UNPACK #-} !Year+ , _d_mon :: !(Month cal)+ , _d_mday :: {-# UNPACK #-} !Day+ , _d_wday :: !(DayOfWeek cal)+ } deriving (Generic, Typeable)++-- |+-- A struct with time components.+data TimeStruct =+ TimeStruct+ { _t_hour :: {-# UNPACK #-} !Hour+ , _t_min :: {-# UNPACK #-} !Minute+ , _t_sec :: {-# UNPACK #-} !Double+ } deriving (Data, Eq, Generic, Show, Typeable)++-- |+-- A struct with date and time components.+data DateTimeStruct (cal :: Calendar) =+ DateTimeStruct+ { _dt_year :: {-# UNPACK #-} !Year+ , _dt_mon :: !(Month cal)+ , _dt_mday :: {-# UNPACK #-} !Day+ , _dt_wday :: !(DayOfWeek cal)+ , _dt_hour :: {-# UNPACK #-} !Hour+ , _dt_min :: {-# UNPACK #-} !Minute+ , _dt_sec :: {-# UNPACK #-} !Double+ } deriving (Generic, Typeable)++-- |+-- A struct with date and time zone components.+data LocalDateStruct (cal :: Calendar) =+ LocalDateStruct+ { _ld_year :: {-# UNPACK #-} !Year+ , _ld_mon :: !(Month cal)+ , _ld_mday :: {-# UNPACK #-} !Day+ , _ld_wday :: !(DayOfWeek cal)+ , _ld_zone :: {-# UNPACK #-} !TimeZone+ } deriving (Generic, Typeable)++-- |+-- A struct with time and time zone components.+data LocalTimeStruct =+ LocalTimeStruct+ { _lt_hour :: {-# UNPACK #-} !Hour+ , _lt_min :: {-# UNPACK #-} !Minute+ , _lt_sec :: {-# UNPACK #-} !Double+ , _lt_zone :: {-# UNPACK #-} !TimeZone+ } deriving (Data, Eq, Generic, Show, Typeable)++-- |+-- A struct with date, time, and time zone components.+data LocalDateTimeStruct (cal :: Calendar) =+ LocalDateTimeStruct+ { _ldt_year :: {-# UNPACK #-} !Year+ , _ldt_mon :: !(Month cal)+ , _ldt_mday :: {-# UNPACK #-} !Day+ , _ldt_wday :: !(DayOfWeek cal)+ , _ldt_hour :: {-# UNPACK #-} !Hour+ , _ldt_min :: {-# UNPACK #-} !Minute+ , _ldt_sec :: {-# UNPACK #-} !Double+ , _ldt_zone :: {-# UNPACK #-} !TimeZone+ } deriving (Generic, Typeable)++deriving instance (Data (Month cal), Data (DayOfWeek cal), Typeable cal) => Data (DateStruct cal)+deriving instance (Data (Month cal), Data (DayOfWeek cal), Typeable cal) => Data (DateTimeStruct cal)+deriving instance (Data (Month cal), Data (DayOfWeek cal), Typeable cal) => Data (LocalDateStruct cal)+deriving instance (Data (Month cal), Data (DayOfWeek cal), Typeable cal) => Data (LocalDateTimeStruct cal)++deriving instance (Eq (Month cal), Eq (DayOfWeek cal)) => Eq (DateStruct cal)+deriving instance (Eq (Month cal), Eq (DayOfWeek cal)) => Eq (DateTimeStruct cal)+deriving instance (Eq (Month cal), Eq (DayOfWeek cal)) => Eq (LocalDateStruct cal)+deriving instance (Eq (Month cal), Eq (DayOfWeek cal)) => Eq (LocalDateTimeStruct cal)++deriving instance (Show (Month cal), Show (DayOfWeek cal)) => Show (DateStruct cal)+deriving instance (Show (Month cal), Show (DayOfWeek cal)) => Show (DateTimeStruct cal)+deriving instance (Show (Month cal), Show (DayOfWeek cal)) => Show (LocalDateStruct cal)+deriving instance (Show (Month cal), Show (DayOfWeek cal)) => Show (LocalDateTimeStruct cal)++instance (NFData (Month cal), NFData (DayOfWeek cal)) => NFData (DateStruct cal)+instance (NFData (Month cal), NFData (DayOfWeek cal)) => NFData (DateTimeStruct cal)+instance (NFData (Month cal), NFData (DayOfWeek cal)) => NFData (LocalDateStruct cal)+instance (NFData (Month cal), NFData (DayOfWeek cal)) => NFData (LocalDateTimeStruct cal)++instance NFData TimeStruct+instance NFData LocalTimeStruct++-- |+-- Decompose a floating point number into second and millisecond components.+properFracMillis :: RealFrac a => a -> (Second, Millis)+{-# SPECIALISE properFracMillis :: Double -> (Second, Millis) #-}+properFracMillis frac = if millis == 1000 then (sec + 1, 0) else res+ where res@(sec, millis) = fmap (round . (*) 1000) $ properFraction frac++-- |+-- Decompose a floating point number into second and microsecond components.+properFracMicros :: RealFrac a => a -> (Second, Micros)+{-# SPECIALISE properFracMicros :: Double -> (Second, Micros) #-}+properFracMicros frac = if micros == 1000000 then (sec + 1, 0) else res+ where res@(sec, micros) = fmap (round . (*) 1000000) $ properFraction frac++-- |+-- Decompose a floating point number into second and nanosecond components.+properFracNanos :: RealFrac a => a -> (Second, Nanos)+{-# SPECIALISE properFracNanos :: Double -> (Second, Nanos) #-}+properFracNanos frac = if nanos == 1000000000 then (sec + 1, 0) else res+ where res@(sec, nanos) = fmap (round . (*) 1000000000) $ properFraction frac++-- |+-- Decompose a floating point number into second and picosecond components.+properFracPicos :: RealFrac a => a -> (Second, Picos)+{-# SPECIALISE properFracPicos :: Double -> (Second, Picos) #-}+properFracPicos frac = if picos == 1000000000000 then (sec + 1, 0) else res+ where res@(sec, picos) = fmap (round . (*) 1000000000000) $ properFraction frac
+ Data/Time/Exts/Format.hs view
@@ -0,0 +1,48 @@+-- |+-- Module : Data.Time.Exts.Format+-- Copyright : 2013-2016 Enzo Haussecker+-- License : BSD3+-- Maintainer : Enzo Haussecker <enzo@sovereign.io>+-- Stability : Stable+--+-- A list of time format directives.++module Data.Time.Exts.Format (++ -- * Format Text+ Format++ ) where++import Data.Text (Text)++-- |+-- Format text is composed of time format directives, each matching data described below.+--+-- [@%%@] % literal.+-- [@%A@] Full weekday name according to the current locale.+-- [@%B@] Full month name according to the current locale.+-- [@%D@] Equivalent to %m\/%d\/%y.+-- [@%F@] Equivalent to %Y-%m-%d.+-- [@%H@] Hour of the day using the 24-hour clock (00..23).+-- [@%I@] Hour of the day using the 12-hour clock (01..12).+-- [@%M@] Minute of the hour (00..59).+-- [@%P@] Like %p, the period of the day according to the current locale, but lowercase.+-- [@%R@] Equivalent to %H:%M.+-- [@%S@] Second of the minute (00..60).+-- [@%T@] Equivalent to %H:%M:%S.+-- [@%Y@] Year of the era (1970..9999).+-- [@%Z@] Alphabetic time zone abbreviation.+-- [@%a@] Abbreviated weekday name according to the current locale.+-- [@%b@] Abbreviated month name according to the current locale.+-- [@%d@] Day of the month (01..31).+-- [@%e@] Like %d, the day of the month, but a leading zero is replaced with a space.+-- [@%f@] Fraction of the second prefixed by a period (.0..999999999).+-- [@%h@] Equivalent to %b.+-- [@%l@] Like %I, the hour of the day using the 12-hour clock, but a leading zero is replaced with a space.+-- [@%m@] Month of the year (01..12).+-- [@%p@] Period of the day according to the current locale.+-- [@%r@] Equivalent to %I:%M:%S %p.+-- [@%y@] Year of the era without the century (00..99).+-- [@%z@] Numeric time zone.+type Format = Text
+ Data/Time/Exts/Lens.hs view
@@ -0,0 +1,24 @@+-- |+-- Module : Data.Time.Exts.Lens+-- Copyright : 2013-2016 Enzo Haussecker+-- License : BSD3+-- Maintainer : Enzo Haussecker <enzo@sovereign.io>+-- Stability : Stable+--+-- A lens-based interface to date and time data structures.++{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS -fno-warn-missing-signatures #-}++module Data.Time.Exts.Lens where++import Data.Time.Exts.Base+import Lens.Simple++makeLenses ''DateStruct+makeLenses ''TimeStruct+makeLenses ''DateTimeStruct+makeLenses ''LocalDateStruct+makeLenses ''LocalTimeStruct+makeLenses ''LocalDateTimeStruct
+ Data/Time/Exts/Parser.hs view
@@ -0,0 +1,347 @@+-- |+-- Module : Data.Time.Exts.Parser+-- Copyright : 2013-2016 Enzo Haussecker+-- License : BSD3+-- Maintainer : Enzo Haussecker <enzo@sovereign.io>+-- Stability : Stable++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS -fno-warn-missing-signatures #-}++module Data.Time.Exts.Parser (++ -- * Parser+ runParser++ -- * State+ , ParserState(..)+ , defaultParserState++ -- * Lenses+ , ps_year+ , ps_mon+ , ps_mday+ , ps_wday+ , ps_hour+ , ps_min+ , ps_sec+ , ps_frac+ , ps_ampm+ , ps_zone++ ) where++import Control.Applicative ((<|>))+import Control.Arrow ((***))+import Control.Monad (foldM, join, replicateM)+import Control.Monad.State.Strict (State, execState)+import Data.Attoparsec.Text (Parser, char, digit, many', option, parseOnly, string, take, takeWhile1, try)+import Data.Char (isAlpha)+import Data.Foldable (asum)+import Data.Int (Int64)+import Data.Text (Text, length, pack, toLower, unpack)+import Data.Time (TimeZone(..), utc)+import Data.Time.Exts.Base (Calendar(..), Day, DayOfWeek(..), Hour, Minute, Month(..), Year)+import Data.Time.Exts.Format (Format)+import Data.Time.Zones (LocalToUTCResult(..), TZ, localTimeToUTCFull)+import Data.Time.Zones.Internal (int64PairToLocalTime)+import Lens.Simple (Setter', (.=), makeLenses)+import Prelude hiding (length, take)+import System.Locale (TimeLocale(..))++-- |+-- Parser state.+data ParserState (cal :: Calendar) =+ ParserState+ { _ps_year :: Year+ , _ps_mon :: Month cal+ , _ps_mday :: Day+ , _ps_wday :: DayOfWeek cal+ , _ps_hour :: Hour+ , _ps_min :: Minute+ , _ps_sec :: Double+ , _ps_frac :: Double -> Double+ , _ps_ampm :: Hour -> Hour+ , _ps_zone :: Int64 -> Either String TimeZone+ }++-- |+-- Default parser state.+defaultParserState :: ParserState 'Gregorian+defaultParserState = ParserState 1970 January 1 Thursday 0 0 0.0 id id (const (return utc))++makeLenses ''ParserState++-- |+-- Create a timestamp parser from the given format text and apply it to the given input text. Return the final parser state or an error message if the parser failed.+runParser+ :: Bounded (Month cal)+ => Enum (DayOfWeek cal)+ => Enum (Month cal)+ => TimeLocale+ -> Maybe TZ+ -> ParserState cal+ -> Format+ -> Text+ -> Either String (ParserState cal)+runParser locale tzdata state format input = join (fmap (flip parseOnly input . fmap (flip execState state . sequence) . sequence) (parseOnly (many' (create locale tzdata)) format))++-- |+-- Create a timestamp parser.+create+ :: Bounded (Month cal)+ => Enum (DayOfWeek cal)+ => Enum (Month cal)+ => TimeLocale+ -> Maybe TZ+ -> Parser (Parser (State (ParserState cal) ()))+create locale tzdata =++ --- Literals+ percent++ --- Components+ <|> match "%A" ps_wday (dayLong locale)+ <|> match "%B" ps_mon (monthLong locale)+ <|> match "%H" ps_hour (int 2)+ <|> match "%I" ps_hour (int 2)+ <|> match "%M" ps_min (int 2)+ <|> match "%P" ps_ampm (period locale toLower)+ <|> match "%S" ps_sec (second)+ <|> match "%Y" ps_year (int 4)+ <|> match "%Z" ps_zone (zone tzdata)+ <|> match "%a" ps_wday (dayShort locale)+ <|> match "%b" ps_mon (monthShort locale)+ <|> match "%d" ps_mday (int 2)+ <|> match "%e" ps_mday (int'2)+ <|> match "%f" ps_frac (decimal)+ <|> match "%h" ps_mon (monthShort locale)+ <|> match "%l" ps_hour (int'2)+ <|> match "%m" ps_mon (month)+ <|> match "%p" ps_ampm (period locale id)+ <|> match "%y" ps_year (year)+ <|> match "%z" ps_zone (zone tzdata)++ --- Combinators+ <|> america+ <|> iso8601+ <|> clock12 locale+ <|> clock24+ <|> clock24Short++ --- Other+ <|> text++-- |+-- Match a percent literal.+percent :: Parser (Parser (State (ParserState cal) ()))+percent = do+ _ <- string "%%"+ return $ do+ _ <- char '%'+ return $ return ()++-- |+-- Match a percent code.+match+ :: Enum (DayOfWeek cal)+ => Enum (Month cal)+ => Text+ -> Setter' (ParserState cal) a+ -> Parser a+ -> Parser (Parser (State (ParserState cal) ()))+match code field parser = do+ _ <- string code+ return $ do+ p <- parser+ return $ field .= p++-- |+-- Match a date in American format.+america :: Bounded (Month cal) => Enum (Month cal) => Parser (Parser (State (ParserState cal) ()))+america = do+ _ <- string "%D"+ return $ do+ m <- month+ _ <- char '/'+ d <- int 2+ _ <- char '/'+ y <- year+ return $ do+ ps_year .= y+ ps_mon .= m+ ps_mday .= d++-- |+-- Match a date in ISO 8601 format.+iso8601 :: Bounded (Month cal) => Enum (Month cal) => Parser (Parser (State (ParserState cal) ()))+iso8601 = do+ _ <- string "%F"+ return $ do+ y <- int 4+ _ <- char '-'+ m <- month+ _ <- char '-'+ d <- int 2+ return $ do+ ps_year .= y+ ps_mon .= m+ ps_mday .= d++-- |+-- Match a time in 12-hour clock format.+clock12 :: TimeLocale -> Parser (Parser (State (ParserState cal) ()))+clock12 locale = do+ _ <- string "%r"+ return $ do+ h <- int 2+ _ <- char ':'+ m <- int 2+ _ <- char ':'+ s <- second+ _ <- char ' '+ p <- period locale id+ return $ do+ ps_hour .= h+ ps_min .= m+ ps_sec .= s+ ps_ampm .= p++-- |+-- Match a time in 24-hour clock format.+clock24 :: Parser (Parser (State (ParserState cal) ()))+clock24 = do+ _ <- string "%T"+ return $ do+ h <- int 2+ _ <- char ':'+ m <- int 2+ _ <- char ':'+ s <- second+ return $ do+ ps_hour .= h+ ps_min .= m+ ps_sec .= s++-- |+-- Same as 'clock24', but with the seconds omitted.+clock24Short :: Parser (Parser (State (ParserState cal) ()))+clock24Short = do+ _ <- string "%R"+ return $ do+ h <- int 2+ _ <- char ':'+ m <- int 2+ return $ do+ ps_hour .= h+ ps_min .= m++-- |+-- Match any other character sequence.+text :: Parser (Parser (State (ParserState cal) ()))+text = do+ src <- takeWhile1 (/='%')+ return $ do+ tgt <- take $ length src+ if src == tgt+ then return $ return ()+ else fail "text: mismatch"++-- |+-- Create a parser from key-value pairs.+fromList :: [(Text, a)] -> Parser a+fromList = asum . fmap (uncurry (*>) . (string *** return))++-- |+-- Parse an integer having the given number of digits.+int :: Integral a => Read a => Int -> Parser a+int = fmap (fromInteger . read) . flip replicateM digit++-- |+-- Parse an integer having two digits or one digit preceded by a space.+int'2 :: Integral a => Read a => Parser a+int'2 = int 2 <|> (char ' ' *> int 1)++-- |+-- Parse a year in two-digit format.+year :: Parser Year+year = fix <$> int 2 where fix n = n + if n < 70 then 2000 else 1900++-- |+-- Parse a month in two-digit format.+month :: forall cal . Bounded (Month cal) => Enum (Month cal) => Parser (Month cal)+month = do+ n <- int 2+ if fromEnum (minBound :: Month cal) <= n &&+ fromEnum (maxBound :: Month cal) >= n+ then return $! toEnum n+ else fail "month: out of bounds"++-- |+-- Parse a month in short text format.+monthShort :: Enum (Month cal) => TimeLocale -> Parser (Month cal)+monthShort = fromList . zipWith (\n (_, t) -> (pack t, toEnum n)) [1..] . months++-- |+-- Parse a month in long text format.+monthLong :: Enum (Month cal) => TimeLocale -> Parser (Month cal)+monthLong = fromList . zipWith (\n (t, _) -> (pack t, toEnum n)) [1..] . months++-- |+-- Parse a day of week in short text format.+dayShort :: Enum (DayOfWeek cal) => TimeLocale -> Parser (DayOfWeek cal)+dayShort = fromList . zipWith (\n (_, t) -> (pack t, toEnum n)) [1..] . wDays++-- |+-- Parse a day of week in long text format.+dayLong :: Enum (DayOfWeek cal) => TimeLocale -> Parser (DayOfWeek cal)+dayLong = fromList . zipWith (\n (t, _) -> (pack t, toEnum n)) [1..] . wDays++-- |+-- Parse a second in two-digit format.+second :: Parser Double+second = toEnum <$> int 2++-- |+-- Parse a decimal having up to nine digits.+decimal :: Parser (Double -> Double)+decimal = char '.' *> do+ (n, m) <- foldM step (0, 0) [1.. 9]+ return $ (+) (toEnum n * 10 ** (- toEnum m))+ where step :: (Int, Int) -> Int -> Parser (Int, Int)+ step acc@(!n, _) m = option acc (try (fmap ((, m) . (+) (10 * n) . subtract 48 . fromEnum) digit))++-- |+-- Parse a period.+period :: TimeLocale -> (Text -> Text) -> Parser (Hour -> Hour)+period TimeLocale { amPm = (am, pm) } format = fromList+ [+ (format (pack am), \ case 12 -> 00; x -> x),+ (format (pack pm), \ case 12 -> 12; x -> x + 12)+ ]++-- |+-- Parse a time zone.+zone :: Maybe TZ -> Parser (Int64 -> Either String TimeZone)+zone = \ case+ Nothing -> fail "zone: no time zone data"+ Just tzdata -> do+ name <- unpack <$> takeWhile1 isAlpha+ return $ \ base -> do+ let time = int64PairToLocalTime base 0+ case localTimeToUTCFull tzdata time of+ LTUUnique {..} | timeZoneName _ltuZone == name -> Right _ltuZone+ LTUAmbiguous {..} | timeZoneName _ltuFirstZone == name -> Right _ltuFirstZone+ LTUAmbiguous {..} | timeZoneName _ltuSecondZone == name -> Right _ltuSecondZone+ _ -> Left $ "unmatched acronym: " ++ name
+ Data/Time/Exts/UTC.hs view
@@ -0,0 +1,442 @@+-- |+-- Module : Data.Time.Exts.UTC+-- Copyright : 2013-2016 Enzo Haussecker+-- License : BSD3+-- Maintainer : Enzo Haussecker <enzo@sovereign.io>+-- Stability : Stable+--+-- A native implementation of Coordinated Universal Time.++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS -fno-warn-name-shadowing #-}++module Data.Time.Exts.UTC (++ -- * Timestamps+ UTCDate(..)+ , UTCDateTime(..)+ , UTCDateTimeNanos(..)++ -- * Create+ , createUTCDate+ , createUTCDateTime+ , createUTCDateTimeNanos++ -- * Get+ , getCurrentUTCDate+ , getCurrentUTCDateTime+ , getCurrentUTCDateTimeNanos++ -- * Parse+ , parseUTCDate+ , parseUTCDateTime+ , parseUTCDateTimeNanos++ ) where++import Control.Arrow ((***), first)+import Control.DeepSeq (NFData)+import Control.Monad (join)+import Data.Data (Data, Typeable)+import Data.Int (Int32, Int64)+import Data.Text (Text)+import Data.Time.Zones (utcTZ)+import Foreign.Ptr (plusPtr)+import Foreign.Storable (Storable(..))+import GHC.Generics (Generic)+import Lens.Simple (over)+import System.Locale (TimeLocale)+import System.Random (Random(..))+import Text.Printf (printf)++import Data.Time.Exts.Base+import Data.Time.Exts.Format+import Data.Time.Exts.Lens+import Data.Time.Exts.Parser+import Data.Time.Exts.Unix+import Data.Time.Exts.Util++-- |+-- Days since Unix epoch.+newtype UTCDate cal = UTCDate (UnixDate cal)+ deriving (Data, Eq, Generic, NFData, Ord, Storable, Typeable)++-- |+-- Seconds since Unix epoch (including leap seconds).+newtype UTCDateTime (cal :: Calendar) = UTCDateTime Int64+ deriving (Data, Eq, Generic, NFData, Ord, Storable, Typeable)++-- |+-- Nanoseconds since Unix epoch (including leap seconds).+data UTCDateTimeNanos (cal :: Calendar) = UTCDateTimeNanos {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int32+ deriving (Data, Eq, Generic, Ord, Typeable)++deriving instance Bounded (UTCDate 'Gregorian)++instance Bounded (UTCDateTime 'Gregorian) where++ -- 12:00:00 AM Thu Jan 01 1970 UTC.+ minBound = UTCDateTime 0++ -- 11:59:59 PM Fri Dec 31 9999 UTC.+ maxBound = UTCDateTime 253402300827++instance Bounded (UTCDateTimeNanos 'Gregorian) where++ -- 12:00:00.000000000 AM Thu Jan 01 1970 UTC.+ minBound = UTCDateTimeNanos 0 0++ -- 11:59:59.999999999 PM Fri Dec 31 9999 UTC.+ maxBound = UTCDateTimeNanos 253402300827 999999999++deriving instance Enum (UTCDate 'Gregorian)++instance Enum (UTCDateTime 'Gregorian) where++ -- Next second.+ succ = flip plus (Second 1)++ -- Previous second.+ pred = flip plus (- Second 1)++ -- Denumerate a UTC timestamp.+ fromEnum (UTCDateTime base) = fromIntegral base++ -- Enumerate a UTC timestamp.+ toEnum base =+ if minBound <= time && time <= maxBound then time+ else error "toEnum{UTCDateTime 'Gregorian}: out of bounds"+ where time = UTCDateTime $ fromIntegral base++instance Human (UTCDate 'Gregorian) where++ -- Define the Gregorian components of a UTC datestamp.+ type Components (UTCDate 'Gregorian) = DateStruct 'Gregorian++ -- Pack a UTC datestamp from Gregorian components.+ pack DateStruct {..} =+ createUTCDate _d_year _d_mon _d_mday++ -- Unpack a UTC datestamp to Gregorian components.+ unpack (UTCDate date) = unpack date++instance Human (UTCDateTime 'Gregorian) where++ -- Define the Gregorian components of a UTC timestamp.+ type Components (UTCDateTime 'Gregorian) = DateTimeStruct 'Gregorian++ -- Pack a UTC timestamp from Gregorian components.+ pack DateTimeStruct {..} =+ createUTCDateTime _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec+ where sec = round _dt_sec++ -- Unpack a UTC timestamp to Gregorian components.+ unpack (UTCDateTime base) =+ over dt_sec (+ leap) (unpack time)+ where time = UnixDateTime unix :: UnixDateTime 'Gregorian+ (,) unix leap = baseUTCToUnix base++instance Human (UTCDateTimeNanos 'Gregorian) where++ -- Define the Gregorian components of a UTC timestamp with nanosecond granularity.+ type Components (UTCDateTimeNanos 'Gregorian) = DateTimeStruct 'Gregorian++ -- Pack a UTC timestamp with nanosecond granularity from Gregorian components.+ pack DateTimeStruct {..} =+ createUTCDateTimeNanos _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec nsec+ where (,) sec nsec = properFracNanos _dt_sec++ -- Unpack a UTC timestamp with nanosecond granularity to Gregorian components.+ unpack (UTCDateTimeNanos base nsec) =+ over dt_sec (+ leap) (unpack time)+ where time = UnixDateTimeNanos unix nsec :: UnixDateTimeNanos 'Gregorian+ (,) unix leap = baseUTCToUnix base++instance Math (UTCDate 'Gregorian) Day where++ -- Compute the day duration between two UTC datestamps.+ duration (UTCDate old) (UTCDate new) = duration old new++ -- Add days to a UTC datestamp.+ plus (UTCDate date) days = UTCDate (plus date days)++instance Math (UTCDateTime 'Gregorian) Second where++ -- Compute the second duration between two UTC timestamps.+ duration (UTCDateTime old) (UTCDateTime new) = fromIntegral (new - old)++ -- Add seconds to a UTC timestamp.+ plus (UTCDateTime base) seconds =+ if minBound <= time && time <= maxBound then time+ else error "plus{UTCDateTime 'Gregorian, Second}: out of bounds"+ where time = UTCDateTime (base + fromIntegral seconds)++instance Math (UTCDateTimeNanos 'Gregorian) Second where++ -- Compute the second duration between two UTC timestamps with nanosecond granularity.+ duration (UTCDateTimeNanos old _) (UTCDateTimeNanos new _) = fromIntegral (new - old)++ -- Add seconds to a UTC timestamp with nanosecond granularity.+ plus (UTCDateTimeNanos base nsec) seconds =+ if minBound <= time && time <= maxBound then time+ else error "plus{UTCDateTimeNanos 'Gregorian, Second}: out of bounds"+ where time = UTCDateTimeNanos (base + fromIntegral seconds) nsec++instance Math (UTCDateTimeNanos 'Gregorian) Millis where++ -- Compute the millisecond duration between two UTC timestamps with nanosecond granularity.+ duration old new = fold new - fold old+ where fold (UTCDateTimeNanos base nsec) =+ fromIntegral base * 1000 + fromIntegral (div nsec 1000000)++ -- Add milliseconds to a UTC timestamp with nanosecond granularity.+ plus (UTCDateTimeNanos base nsec) millis =+ if minBound <= time && time <= maxBound then time+ else error "plus{UTCDateTimeNanos 'Gregorian, Millis}: out of bounds"+ where nsum = fromIntegral nsec + fromIntegral millis * 1000000+ time = uncurry UTCDateTimeNanos ((***) (+ base) fromIntegral (divMod nsum 1000000000))++instance Math (UTCDateTimeNanos 'Gregorian) Micros where++ -- Compute the microsecond duration between two UTC timestamps with nanosecond granularity.+ duration old new = fold new - fold old+ where fold (UTCDateTimeNanos base nsec) =+ fromIntegral base * 1000000 + fromIntegral (div nsec 1000)++ -- Add microseconds to a UTC timestamp with nanosecond granularity.+ plus (UTCDateTimeNanos base nsec) micros =+ if minBound <= time && time <= maxBound then time+ else error "plus{UTCDateTimeNanos 'Gregorian, Micros}: out of bounds"+ where nsum = fromIntegral nsec + fromIntegral micros * 1000+ time = uncurry UTCDateTimeNanos ((***) (+ base) fromIntegral (divMod nsum 1000000000))++instance Math (UTCDateTimeNanos 'Gregorian) Nanos where++ -- Compute the nanosecond duration between two UTC timestamps with nanosecond granularity.+ duration old new =+ if toInteger (minBound :: Int64) <= res &&+ toInteger (maxBound :: Int64) >= res then fromInteger res+ else error "duration{UTCDateTimeNanos 'Gregorian, Nanos}: integer overflow"+ where res = fold new - fold old+ fold (UTCDateTimeNanos base nsec) =+ toInteger base * 1000000000 + toInteger nsec++ -- Add nanoseconds to a UTC timestamp with nanosecond granularity.+ plus (UTCDateTimeNanos base nsec) nanos =+ if minBound <= time && time <= maxBound then time+ else error "plus{UTCDateTimeNanos 'Gregorian, Nanos}: out of bounds"+ where nsum = fromIntegral nsec + fromIntegral nanos+ time = uncurry UTCDateTimeNanos ((***) (+ base) fromIntegral (divMod nsum 1000000000))++instance NFData (UTCDateTimeNanos cal)++deriving instance Random (UTCDate 'Gregorian)++instance Random (UTCDateTime 'Gregorian) where++ -- Generate a random UTC timestamp.+ random = first toEnum . randomR (fromEnum a, fromEnum b)+ where a = minBound :: UTCDateTime 'Gregorian+ b = maxBound :: UTCDateTime 'Gregorian++ -- Generate a random UTC timestamp uniformly distributed on the closed interval.+ randomR (a, b) = first toEnum . randomR (fromEnum a, fromEnum b)++instance Random (UTCDateTimeNanos 'Gregorian) where++ -- Generate a random UTC timestamp with nanosecond granularity.+ random = first toNano . randomR (fromNano a, fromNano b)+ where a = minBound :: UTCDateTimeNanos 'Gregorian+ b = maxBound :: UTCDateTimeNanos 'Gregorian++ -- Generate a random UTC timestamp with nanosecond granularity uniformly distributed on the closed interval.+ randomR (a, b) = first toNano . randomR (fromNano a, fromNano b)++instance Show (UTCDate 'Gregorian) where++ -- Show a UTC datestamp.+ show (unpack -> DateStruct {..}) =+ printf "%.3s %.3s %02d %4d UTC" wday mon _d_mday _d_year+ where wday = show _d_wday+ mon = show _d_mon++instance Show (UTCDateTime 'Gregorian) where++ -- Show a UTC timestamp.+ show (unpack -> DateTimeStruct {..}) =+ printf "%02d:%02d:%02d %s %.3s %.3s %02d %4d UTC" hour _dt_min sec ampm wday mon _dt_mday _dt_year+ where wday = show _dt_wday+ mon = show _dt_mon+ sec = round _dt_sec :: Second+ (,) ampm hour = getPeriod _dt_hour++instance Show (UTCDateTimeNanos 'Gregorian) where++ -- Show a UTC timestamp with nanosecond granularity.+ show (unpack -> DateTimeStruct {..}) =+ printf "%02d:%02d:%02d.%09d %s %.3s %.3s %02d %4d UTC" hour _dt_min sec nsec ampm wday mon _dt_mday _dt_year+ where wday = show _dt_wday+ mon = show _dt_mon+ (,) sec nsec = properFracNanos _dt_sec+ (,) ampm hour = getPeriod _dt_hour++instance Storable (UTCDateTimeNanos cal) where++ -- Size of UTC timestamp with nanosecond granularity.+ sizeOf = const 12++ -- Alignment of UTC timestamp with nanosecond granularity.+ alignment = sizeOf++ -- Read a UTC timestamp with nanosecond granularity from memory.+ peekElemOff ptr n = do+ let off = 12 * n+ base <- peek (plusPtr ptr (off + 0))+ nsec <- peek (plusPtr ptr (off + 8))+ return $! UTCDateTimeNanos base nsec++ -- Write a UTC timestamp with nanosecond granularity to memory.+ pokeElemOff ptr n (UTCDateTimeNanos base nsec) = do+ let off = 12 * n+ poke (plusPtr ptr (off + 0)) base+ poke (plusPtr ptr (off + 8)) nsec++-- |+-- Create a UTC datestamp.+createUTCDate+ :: Year+ -> Month 'Gregorian+ -> Day+ -> UTCDate 'Gregorian+createUTCDate year mon mday =+ UTCDate $ createUnixDate year mon mday++-- |+-- Create a UTC timestamp.+createUTCDateTime+ :: Year+ -> Month 'Gregorian+ -> Day+ -> Hour+ -> Minute+ -> Second+ -> UTCDateTime 'Gregorian+createUTCDateTime year mon mday hour min sec =+ if minBound <= time && time <= maxBound then time+ else error "createUTCDateTime: out of bounds"+ where UnixDateTime unix = createUnixDateTime year mon mday hour min 0+ time = UTCDateTime base+ base = baseUnixToUTC unix + fromIntegral sec++-- |+-- Create a UTC timestamp with nanosecond granularity.+createUTCDateTimeNanos+ :: Year+ -> Month 'Gregorian+ -> Day+ -> Hour+ -> Minute+ -> Second+ -> Nanos+ -> UTCDateTimeNanos 'Gregorian+createUTCDateTimeNanos year mon mday hour min sec nanos =+ if minBound <= time && time <= maxBound then time+ else error "createUTCDateTimeNanos: out of bounds"+ where UnixDateTime unix = createUnixDateTime year mon mday hour min 0+ time = UTCDateTimeNanos base nsec+ base = baseUnixToUTC unix + fromIntegral sec + extra+ (,) extra nsec = (***) fromIntegral fromIntegral (divMod nanos 1000000000)++-- |+-- Get the current UTC datestamp from the system clock.+getCurrentUTCDate :: IO (UTCDate 'Gregorian)+getCurrentUTCDate = UTCDate <$> getCurrentUnixDate++-- |+-- Get the current UTC timestamp from the system clock.+getCurrentUTCDateTime :: IO (UTCDateTime 'Gregorian)+getCurrentUTCDateTime = do+ UnixDateTime unix <- getCurrentUnixDateTime+ return $! UTCDateTime $ baseUnixToUTC unix++-- |+-- Get the current UTC timestamp with nanosecond granularity from the system clock. Any observed leap second will be spread out over the day to ensure nanosecond continuity at midnight.+getCurrentUTCDateTimeNanos :: IO (UTCDateTimeNanos 'Gregorian)+getCurrentUTCDateTimeNanos = do+ UnixDateTimeNanos unix nsec <- getCurrentUnixDateTimeNanos+ let date = UnixDate (fromIntegral (div base 86400))+ base = baseUnixToUTC unix+ time = UTCDateTimeNanos base nsec+ leap = round (11574.074074074073 * realToFrac (mod unix 86400) :: Double) :: Nanos+ return $! case nextLeap of+ Just ((==) date -> True) -> time `plus` leap+ _ -> time++-- |+-- Parse a UTC datestamp.+parseUTCDate+ :: TimeLocale+ -> Format+ -> Text+ -> Either String (UTCDate 'Gregorian)+parseUTCDate locale format input =+ join $ build <$> runParser locale tzdata defaultParserState format input+ where tzdata = Just utcTZ+ build ParserState {..} = _ps_zone 0 *> do+ return $! createUTCDate _ps_year _ps_mon _ps_mday++-- |+-- Parse a UTC timestamp.+parseUTCDateTime+ :: TimeLocale+ -> Format+ -> Text+ -> Either String (UTCDateTime 'Gregorian)+parseUTCDateTime locale format input =+ join $ build <$> runParser locale tzdata defaultParserState format input+ where tzdata = Just utcTZ+ build ParserState {..} = _ps_zone 0 *> do+ return $! createUTCDateTime _ps_year _ps_mon _ps_mday hour _ps_min sec+ where hour = _ps_ampm _ps_hour+ sec = truncate _ps_sec++-- |+-- Parse a UTC timestamp with nanosecond granularity.+parseUTCDateTimeNanos+ :: TimeLocale+ -> Format+ -> Text+ -> Either String (UTCDateTimeNanos 'Gregorian)+parseUTCDateTimeNanos locale format input =+ join $ build <$> runParser locale tzdata defaultParserState format input+ where tzdata = Just utcTZ+ build ParserState {..} = _ps_zone 0 *> do+ return $! createUTCDateTimeNanos _ps_year _ps_mon _ps_mday hour _ps_min sec nsec+ where hour = _ps_ampm _ps_hour+ (,) sec nsec = properFracNanos $ _ps_frac _ps_sec++-- |+-- Convert an integer into a UTC timestamp with nanosecond granularity.+toNano :: Integer -> UTCDateTimeNanos 'Gregorian+toNano = uncurry UTCDateTimeNanos . (***) fromInteger fromInteger . flip divMod 1000000000++-- |+-- Convert a UTC timestamp with nanosecond granularity into an integer.+fromNano :: UTCDateTimeNanos 'Gregorian -> Integer+fromNano (UTCDateTimeNanos base nsec) = toInteger base * 1000000000 + toInteger nsec++-- |+-- The next leap second insertion date.+nextLeap :: Maybe (UnixDate 'Gregorian)+nextLeap = Just (UnixDate 17166)
+ Data/Time/Exts/Unix.hs view
@@ -0,0 +1,642 @@+-- |+-- Module : Data.Time.Exts.Unix+-- Copyright : 2013-2016 Enzo Haussecker+-- License : BSD3+-- Maintainer : Enzo Haussecker <enzo@sovereign.io>+-- Stability : Stable+--+-- A native implementation of Unix Time.++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS -fno-warn-name-shadowing #-}++module Data.Time.Exts.Unix (++ -- * Timestamps+ UnixDate(..)+ , UnixDateTime(..)+ , UnixDateTimeNanos(..)++ -- * Create+ , createUnixDate+ , createUnixDateTime+ , createUnixDateTimeNanos++ -- * Get+ , getCurrentUnixDate+ , getCurrentUnixDateTime+ , getCurrentUnixDateTimeNanos++ -- * Parse+ , parseUnixDate+ , parseUnixDateTime+ , parseUnixDateTimeNanos++ ) where++import Control.Arrow ((***), first)+import Control.DeepSeq (NFData)+import Data.Data (Data, Typeable)+import Data.Int (Int32, Int64)+import Data.Text (Text)+import Foreign.C.Time (C'timeval(..), getTimeOfDay)+import Foreign.C.Types (CLong(..))+import Foreign.Ptr (plusPtr)+import Foreign.Storable (Storable(..))+import GHC.Generics (Generic)+import Lens.Simple (over)+import System.Locale (TimeLocale)+import System.Random (Random(..))+import Text.Printf (printf)++import Data.Time.Exts.Base+import Data.Time.Exts.Format+import Data.Time.Exts.Lens+import Data.Time.Exts.Parser+import Data.Time.Exts.Util++-- |+-- Days since Unix epoch.+newtype UnixDate (cal :: Calendar) = UnixDate Int32+ deriving (Data, Eq, Generic, NFData, Ord, Storable, Typeable)++-- |+-- Seconds since Unix epoch (excluding leap seconds).+newtype UnixDateTime (cal :: Calendar) = UnixDateTime Int64+ deriving (Data, Eq, Generic, NFData, Ord, Storable, Typeable)++-- |+-- Nanoseconds since Unix epoch (excluding leap seconds).+data UnixDateTimeNanos (cal :: Calendar) = UnixDateTimeNanos {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int32+ deriving (Data, Eq, Generic, Ord, Typeable)++instance Bounded (UnixDate 'Gregorian) where++ -- Thu Jan 01 1970.+ minBound = UnixDate 0++ -- Fri Dec 31 9999.+ maxBound = UnixDate 2932896++instance Bounded (UnixDateTime 'Gregorian) where++ -- 12:00:00 AM Thu Jan 01 1970.+ minBound = UnixDateTime 0++ -- 11:59:59 PM Fri Dec 31 9999.+ maxBound = UnixDateTime 253402300799++instance Bounded (UnixDateTimeNanos 'Gregorian) where++ -- 12:00:00.000000000 AM Thu Jan 01 1970.+ minBound = UnixDateTimeNanos 0 0++ -- 11:59:59.999999999 PM Fri Dec 31 9999.+ maxBound = UnixDateTimeNanos 253402300799 999999999++instance Enum (UnixDate 'Gregorian) where++ -- Next day.+ succ = flip plus (Day 1)++ -- Previous day.+ pred = flip plus (- Day 1)++ -- Denumerate a Unix datestamp.+ fromEnum (UnixDate base) = fromIntegral base++ -- Enumerate a Unix datestamp.+ toEnum base =+ if minBound <= date && date <= maxBound then date+ else error "toEnum{UnixDate 'Gregorian}: out of bounds"+ where date = UnixDate $ fromIntegral base++instance Enum (UnixDateTime 'Gregorian) where++ -- Next second.+ succ = flip plus (Second 1)++ -- Previous second.+ pred = flip plus (- Second 1)++ -- Denumerate a Unix timestamp.+ fromEnum (UnixDateTime base) = fromIntegral base++ -- Enumerate a Unix timestamp.+ toEnum base =+ if minBound <= time && time <= maxBound then time+ else error "toEnum{UnixDateTime 'Gregorian}: out of bounds"+ where time = UnixDateTime $ fromIntegral base++instance Human (UnixDate 'Gregorian) where++ -- Define the Gregorian components of a Unix datestamp.+ type Components (UnixDate 'Gregorian) = DateStruct 'Gregorian++ -- Pack a Unix datestamp from Gregorian components.+ pack DateStruct {..} =+ createUnixDate _d_year _d_mon _d_mday++ -- Unpack a Unix datestamp to Gregorian components.+ unpack (UnixDate base) =+ rec 1970 (Day base) where+ rec !year !day =+ if day >= size+ then rec (year + 1) (day - size)+ else DateStruct year mon mday wday+ where+ wday = toEnum (1 + mod (fromIntegral base + 4) 7)+ leap = isLeapYear year+ size = if leap then 366 else 365+ (mon, mday) =+ if leap+ then if day >= 182+ then if day >= 274+ then if day >= 335+ then (December, day - 334)+ else if day >= 305+ then (November, day - 304)+ else (October, day - 273)+ else if day >= 244+ then (September, day - 243)+ else if day >= 213+ then (August, day - 212)+ else (July, day - 181)+ else if day >= 091+ then if day >= 152+ then (June, day - 151)+ else if day >= 121+ then (May, day - 120)+ else (April, day - 090)+ else if day >= 060+ then (March, day - 059)+ else if day >= 031+ then (February, day - 030)+ else (January, day + 001)+ else if day >= 181+ then if day >= 273+ then if day >= 334+ then (December, day - 333)+ else if day >= 304+ then (November, day - 303)+ else (October, day - 272)+ else if day >= 243+ then (September, day - 242)+ else if day >= 212+ then (August, day - 211)+ else (July, day - 180)+ else if day >= 090+ then if day >= 151+ then (June, day - 150)+ else if day >= 120+ then (May, day - 119)+ else (April, day - 089)+ else if day >= 059+ then (March, day - 058)+ else if day >= 031+ then (February, day - 030)+ else (January, day + 001)++instance Human (UnixDateTime 'Gregorian) where++ -- Define the Gregorian components of a Unix timestamp.+ type Components (UnixDateTime 'Gregorian) = DateTimeStruct 'Gregorian++ -- Pack a Unix timestamp from Gregorian components.+ pack DateTimeStruct {..} =+ createUnixDateTime _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec+ where sec = round _dt_sec++ -- Unpack a Unix timestamp to Gregorian components.+ unpack (UnixDateTime base) =+ DateTimeStruct _d_year _d_mon _d_mday _d_wday hour min sec where+ DateStruct {..} = unpack (UnixDate day :: UnixDate 'Gregorian)+ (day, hms) = fromIntegral *** fromIntegral $ divMod base 86400+ (hour, ms) = fromIntegral <$> divMod hms 3600+ (min, sec) = realToFrac <$> divMod ms 0060++instance Human (UnixDateTimeNanos 'Gregorian) where++ -- Define the Gregorian components of a Unix timestamp with nanosecond granularity.+ type Components (UnixDateTimeNanos 'Gregorian) = DateTimeStruct 'Gregorian++ -- Pack a Unix timestamp with nanosecond granularity from Gregorian components.+ pack DateTimeStruct {..} =+ createUnixDateTimeNanos _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec nsec+ where (sec, nsec) = properFracNanos _dt_sec++ -- Unpack a Unix timestamp with nanosecond granularity to Gregorian components.+ unpack (UnixDateTimeNanos base nsec) =+ over dt_sec (+ frac) $ unpack time+ where time = UnixDateTime base :: UnixDateTime 'Gregorian+ frac = realToFrac nsec / 1000000000++instance Math (UnixDate 'Gregorian) Day where++ -- Compute the day duration between two Unix datestamps.+ duration (UnixDate old) (UnixDate new) = fromIntegral (new - old)++ -- Add days to a Unix datestamp.+ plus (UnixDate base) days =+ if minBound <= date && date <= maxBound then date+ else error "plus{UnixDate 'Gregorian, Day}: out of bounds"+ where date = UnixDate (base + fromIntegral days)++instance Math (UnixDateTime 'Gregorian) Day where++ -- Compute the day duration between two Unix timestamps.+ duration (UnixDateTime old) (UnixDateTime new) = fromIntegral (div (new - old) 86400)++ -- Add days to a Unix timestamp.+ plus (UnixDateTime base) days =+ if minBound <= time && time <= maxBound then time+ else error "plus{UnixDateTime 'Gregorian, Day}: out of bounds"+ where time = UnixDateTime (base + fromIntegral days * 86400)++instance Math (UnixDateTime 'Gregorian) Hour where++ -- Compute the hour duration between two Unix timestamps.+ duration (UnixDateTime old) (UnixDateTime new) = fromIntegral (div (new - old) 3600)++ -- Add hours to a Unix timestamp.+ plus (UnixDateTime base) hours =+ if minBound <= time && time <= maxBound then time+ else error "plus{UnixDateTime 'Gregorian, Hour}: out of bounds"+ where time = UnixDateTime (base + fromIntegral hours * 3600)++instance Math (UnixDateTime 'Gregorian) Minute where++ -- Compute the minute duration between two Unix timestamps.+ duration (UnixDateTime old) (UnixDateTime new) = fromIntegral (div (new - old) 60)++ -- Add minutes to a Unix timestamp.+ plus (UnixDateTime base) minutes =+ if minBound <= time && time <= maxBound then time+ else error "plus{UnixDateTime 'Gregorian, Minute}: out of bounds"+ where time = UnixDateTime (base + fromIntegral minutes * 60)++instance Math (UnixDateTime 'Gregorian) Second where++ -- Compute the second duration between two Unix timestamps.+ duration (UnixDateTime old) (UnixDateTime new) = fromIntegral (new - old)++ -- Add seconds to a Unix timestamp.+ plus (UnixDateTime base) seconds =+ if minBound <= time && time <= maxBound then time+ else error "plus{UnixDateTime 'Gregorian, Second}: out of bounds"+ where time = UnixDateTime (base + fromIntegral seconds)++instance Math (UnixDateTimeNanos 'Gregorian) Day where++ -- Compute the day duration between two Unix timestamps with nanosecond granularity.+ duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = fromIntegral (div (new - old) 86400)++ -- Add days to a Unix timestamp with nanosecond granularity.+ plus (UnixDateTimeNanos base nsec) days =+ if minBound <= time && time <= maxBound then time+ else error "plus{UnixDateTimeNanos 'Gregorian, Day}: out of bounds"+ where time = UnixDateTimeNanos (base + fromIntegral days * 86400) nsec++instance Math (UnixDateTimeNanos 'Gregorian) Hour where++ -- Compute the hour duration between two Unix timestamps with nanosecond granularity.+ duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = fromIntegral (div (new - old) 3600)++ -- Add hours to a Unix timestamp with nanosecond granularity.+ plus (UnixDateTimeNanos base nsec) hours =+ if minBound <= time && time <= maxBound then time+ else error "plus{UnixDateTimeNanos 'Gregorian, Hour}: out of bounds"+ where time = UnixDateTimeNanos (base + fromIntegral hours * 3600) nsec++instance Math (UnixDateTimeNanos 'Gregorian) Minute where++ -- Compute the minute duration between two Unix timestamps with nanosecond granularity.+ duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = fromIntegral (div (new - old) 60)++ -- Add minutes to a Unix timestamp with nanosecond granularity.+ plus (UnixDateTimeNanos base nsec) minutes =+ if minBound <= time && time <= maxBound then time+ else error "plus{UnixDateTimeNanos 'Gregorian, Minute}: out of bounds"+ where time = UnixDateTimeNanos (base + fromIntegral minutes * 60) nsec++instance Math (UnixDateTimeNanos 'Gregorian) Second where++ -- Compute the second duration between two Unix timestamps with nanosecond granularity.+ duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = fromIntegral (new - old)++ -- Add seconds to a Unix timestamp with nanosecond granularity.+ plus (UnixDateTimeNanos base nsec) seconds =+ if minBound <= time && time <= maxBound then time+ else error "plus{UnixDateTimeNanos 'Gregorian, Second}: out of bounds"+ where time = UnixDateTimeNanos (base + fromIntegral seconds) nsec++instance Math (UnixDateTimeNanos 'Gregorian) Millis where++ -- Compute the millisecond duration between two Unix timestamps with nanosecond granularity.+ duration old new = fold new - fold old+ where fold (UnixDateTimeNanos base nsec) =+ fromIntegral base * 1000 + fromIntegral (div nsec 1000000)++ -- Add milliseconds to a Unix timestamp with nanosecond granularity.+ plus (UnixDateTimeNanos base nsec) millis =+ if minBound <= time && time <= maxBound then time+ else error "plus{UnixDateTimeNanos 'Gregorian, Millis}: out of bounds"+ where nsum = fromIntegral nsec + fromIntegral millis * 1000000+ time = uncurry UnixDateTimeNanos ((***) (+ base) fromIntegral (divMod nsum 1000000000))++instance Math (UnixDateTimeNanos 'Gregorian) Micros where++ -- Compute the microsecond duration between two Unix timestamps with nanosecond granularity.+ duration old new = fold new - fold old+ where fold (UnixDateTimeNanos base nsec) =+ fromIntegral base * 1000000 + fromIntegral (div nsec 1000)++ -- Add microseconds to a Unix timestamp with nanosecond granularity.+ plus (UnixDateTimeNanos base nsec) micros =+ if minBound <= time && time <= maxBound then time+ else error "plus{UnixDateTimeNanos 'Gregorian, Micros}: out of bounds"+ where nsum = fromIntegral nsec + fromIntegral micros * 1000+ time = uncurry UnixDateTimeNanos ((***) (+ base) fromIntegral (divMod nsum 1000000000))++instance Math (UnixDateTimeNanos 'Gregorian) Nanos where++ -- Compute the nanosecond duration between two Unix timestamps with nanosecond granularity.+ duration old new =+ if toInteger (minBound :: Int64) <= res &&+ toInteger (maxBound :: Int64) >= res then fromInteger res+ else error "duration{UnixDateTimeNanos 'Gregorian, Nanos}: integer overflow"+ where res = fold new - fold old+ fold (UnixDateTimeNanos base nsec) =+ toInteger base * 1000000000 + toInteger nsec++ -- Add nanoseconds to a Unix timestamp with nanosecond granularity.+ plus (UnixDateTimeNanos base nsec) nanos =+ if minBound <= time && time <= maxBound then time+ else error "plus{UnixDateTimeNanos 'Gregorian, Nanos}: out of bounds"+ where nsum = fromIntegral nsec + fromIntegral nanos+ time = uncurry UnixDateTimeNanos ((***) (+ base) fromIntegral (divMod nsum 1000000000))++instance NFData (UnixDateTimeNanos cal)++instance Random (UnixDate 'Gregorian) where++ -- Generate a random Unix datestamp.+ random = first toEnum . randomR (fromEnum a, fromEnum b)+ where a = minBound :: UnixDate 'Gregorian+ b = maxBound :: UnixDate 'Gregorian++ -- Generate a random Unix datestamp uniformly distributed on the closed interval.+ randomR (a, b) = first toEnum . randomR (fromEnum a, fromEnum b)++instance Random (UnixDateTime 'Gregorian) where++ -- Generate a random Unix timestamp.+ random = first toEnum . randomR (fromEnum a, fromEnum b)+ where a = minBound :: UnixDateTime 'Gregorian+ b = maxBound :: UnixDateTime 'Gregorian++ -- Generate a random Unix timestamp uniformly distributed on the closed interval.+ randomR (a, b) = first toEnum . randomR (fromEnum a, fromEnum b)++instance Random (UnixDateTimeNanos 'Gregorian) where++ -- Generate a random Unix timestamp with nanosecond granularity.+ random = first toNano . randomR (fromNano a, fromNano b)+ where a = minBound :: UnixDateTimeNanos 'Gregorian+ b = maxBound :: UnixDateTimeNanos 'Gregorian++ -- Generate a random Unix timestamp with nanosecond granularity uniformly distributed on the closed interval.+ randomR (a, b) = first toNano . randomR (fromNano a, fromNano b)++instance Show (UnixDate 'Gregorian) where++ -- Show a Unix datestamp.+ show (unpack -> DateStruct {..}) =+ printf "%.3s %.3s %02d %4d" (show _d_wday) (show _d_mon) _d_mday _d_year++instance Show (UnixDateTime 'Gregorian) where++ -- Show a Unix timestamp.+ show (unpack -> DateTimeStruct {..}) =+ printf "%02d:%02d:%02d %s %.3s %.3s %02d %4d" hour _dt_min sec ampm wday mon _dt_mday _dt_year+ where wday = show _dt_wday+ mon = show _dt_mon+ sec = round _dt_sec :: Second+ (,) ampm hour = getPeriod _dt_hour++instance Show (UnixDateTimeNanos 'Gregorian) where++ -- Show a Unix timestamp with nanosecond granularity.+ show (unpack -> DateTimeStruct {..}) =+ printf "%02d:%02d:%02d.%09d %s %.3s %.3s %02d %4d" hour _dt_min sec nsec ampm wday mon _dt_mday _dt_year+ where wday = show _dt_wday+ mon = show _dt_mon+ (,) sec nsec = properFracNanos _dt_sec+ (,) ampm hour = getPeriod _dt_hour++instance Storable (UnixDateTimeNanos cal) where++ -- Size of Unix timestamp with nanosecond granularity.+ sizeOf = const 12++ -- Alignment of Unix timestamp with nanosecond granularity.+ alignment = sizeOf++ -- Read a Unix timestamp with nanosecond granularity from memory.+ peekElemOff ptr n = do+ let off = 12 * n+ base <- peek (plusPtr ptr (off + 0))+ nsec <- peek (plusPtr ptr (off + 8))+ return $! UnixDateTimeNanos base nsec++ -- Write a Unix timestamp with nanosecond granularity to memory.+ pokeElemOff ptr n (UnixDateTimeNanos base nsec) = do+ let off = 12 * n+ poke (plusPtr ptr (off + 0)) base+ poke (plusPtr ptr (off + 8)) nsec++-- |+-- Create a Unix datestamp.+createUnixDate+ :: Year+ -> Month 'Gregorian+ -> Day+ -> UnixDate 'Gregorian+createUnixDate year mon mday =+ if minBound <= date && date <= maxBound then date+ else error "createUnixDate: out of bounds"+ where Day base = unsafeEpochToDate year mon mday+ date = UnixDate base++-- |+-- Create a Unix timestamp.+createUnixDateTime+ :: Year+ -> Month 'Gregorian+ -> Day+ -> Hour+ -> Minute+ -> Second+ -> UnixDateTime 'Gregorian+createUnixDateTime year mon mday hour min sec =+ if minBound <= time && time <= maxBound then time+ else error "createUnixDateTime: out of bounds"+ where Second base = unsafeEpochToDateTime year mon mday hour min sec+ time = UnixDateTime base++-- |+-- Create a Unix timestamp with nanosecond granularity.+createUnixDateTimeNanos+ :: Year+ -> Month 'Gregorian+ -> Day+ -> Hour+ -> Minute+ -> Second+ -> Nanos+ -> UnixDateTimeNanos 'Gregorian+createUnixDateTimeNanos year mon mday hour min sec nanos =+ if minBound <= time && time <= maxBound then time+ else error "createUnixDateTimeNanos: out of bounds"+ where Second base = unsafeEpochToDateTime year mon mday hour min sec+ nsum = fromIntegral nanos+ time = uncurry UnixDateTimeNanos ((***) (+ base) fromIntegral (divMod nsum 1000000000))++-- |+-- Get the current Unix datestamp from the system clock.+getCurrentUnixDate :: IO (UnixDate 'Gregorian)+getCurrentUnixDate =+ getTimeOfDay >>= \ (C'timeval (CLong base) _) ->+ return $! UnixDate (fromIntegral (div base 86400))++-- |+-- Get the current Unix timestamp from the system clock.+getCurrentUnixDateTime :: IO (UnixDateTime 'Gregorian)+getCurrentUnixDateTime =+ getTimeOfDay >>= \ (C'timeval (CLong base) _) ->+ return $! UnixDateTime base++-- |+-- Get the current Unix timestamp with nanosecond granularity from the system clock.+getCurrentUnixDateTimeNanos :: IO (UnixDateTimeNanos 'Gregorian)+getCurrentUnixDateTimeNanos =+ getTimeOfDay >>= \ (C'timeval (CLong base) (CLong usec)) ->+ return $! UnixDateTimeNanos base (fromIntegral usec * 1000)++-- |+-- Parse a Unix datestamp.+parseUnixDate+ :: TimeLocale+ -> Format+ -> Text+ -> Either String (UnixDate 'Gregorian)+parseUnixDate locale format input =+ build <$> runParser locale Nothing defaultParserState format input+ where build ParserState {..} =+ createUnixDate _ps_year _ps_mon _ps_mday++-- |+-- Parse a Unix timestamp.+parseUnixDateTime+ :: TimeLocale+ -> Format+ -> Text+ -> Either String (UnixDateTime 'Gregorian)+parseUnixDateTime locale format input =+ build <$> runParser locale Nothing defaultParserState format input+ where build ParserState {..} =+ createUnixDateTime _ps_year _ps_mon _ps_mday hour _ps_min sec+ where hour = _ps_ampm _ps_hour+ sec = truncate _ps_sec++-- |+-- Parse a Unix timestamp with nanosecond granularity.+parseUnixDateTimeNanos+ :: TimeLocale+ -> Format+ -> Text+ -> Either String (UnixDateTimeNanos 'Gregorian)+parseUnixDateTimeNanos locale format input =+ build <$> runParser locale Nothing defaultParserState format input+ where build ParserState {..} =+ createUnixDateTimeNanos _ps_year _ps_mon _ps_mday hour _ps_min sec nsec+ where hour = _ps_ampm _ps_hour+ (,) sec nsec = properFracNanos $ _ps_frac _ps_sec++-- |+-- Convert an integer into a Unix timestamp with nanosecond granularity.+toNano :: Integer -> UnixDateTimeNanos 'Gregorian+toNano = uncurry UnixDateTimeNanos . (***) fromInteger fromInteger . flip divMod 1000000000++-- |+-- Convert a Unix timestamp with nanosecond granularity into an integer.+fromNano :: UnixDateTimeNanos 'Gregorian -> Integer+fromNano (UnixDateTimeNanos base nsec) = toInteger base * 1000000000 + toInteger nsec++-- |+-- Check if the given year is a leap year.+isLeapYear :: Year -> Bool+isLeapYear year = mod year 400 == 0 || (mod year 100 /= 0 && mod year 4 == 0)++-- |+-- Calculate the number of days that have elapsed between Unix epoch and the given year without performing any bounds check.+unsafeEpochToYear :: Year -> Day+unsafeEpochToYear Year {..} = Day (365 * (getYear - 1970) + div (getYear - 1969) 004 - div (getYear - 1901) 100 + div (getYear - 1601) 400)++-- |+-- Calculate the number of days that have elapsed between Unix epoch and the given Unix datestamp without performing any bounds check.+unsafeEpochToDate :: Year -> Month 'Gregorian -> Day -> Day+unsafeEpochToDate year mon mday =+ unsafeEpochToYear year + yearToMonth leap mon + mday - 1+ where leap = isLeapYear year++-- |+-- Calculate the number of seconds that have elapsed between Unix epoch and the given Unix timestamp without performing any bounds check.+unsafeEpochToDateTime :: Year -> Month 'Gregorian -> Day -> Hour -> Minute -> Second -> Second+unsafeEpochToDateTime year mon mday hour min sec =+ fromIntegral day * 86400 + fromIntegral hour * 3600 + fromIntegral min * 60 + sec+ where day = unsafeEpochToDate year mon mday++-- |+-- Calculate the number of days that have elapsed between January 1st and the given month.+yearToMonth :: Bool -> Month 'Gregorian -> Day+yearToMonth leap =+ if leap+ then \ case+ 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+ January -> 000+ February -> 031+ March -> 059+ April -> 090+ May -> 120+ June -> 151+ July -> 181+ August -> 212+ September -> 243+ October -> 273+ November -> 304+ December -> 334
+ Data/Time/Exts/Util.hs view
@@ -0,0 +1,116 @@+-- |+-- Module : Data.Time.Exts.Util+-- Copyright : 2013-2016 Enzo Haussecker+-- License : BSD3+-- Maintainer : Enzo Haussecker <enzo@sovereign.io>+-- Stability : Stable++module Data.Time.Exts.Util where++import Data.Int+import Data.Time.Exts.Base++-- |+-- Convert Unix seconds into a UTC seconds.+baseUnixToUTC :: Int64 -> Int64+baseUnixToUTC base+ | base >= 1483228800 = base + 28+ | base >= 1435708800 = base + 27+ | base >= 1341100800 = base + 26+ | base >= 1230768000 = base + 25+ | base >= 1136073600 = base + 24+ | base >= 0915148800 = base + 23+ | base >= 0867715200 = base + 22+ | base >= 0820454400 = base + 21+ | base >= 0773020800 = base + 20+ | base >= 0741484800 = base + 19+ | base >= 0709948800 = base + 18+ | base >= 0662688000 = base + 17+ | base >= 0631152000 = base + 16+ | base >= 0567993600 = base + 15+ | base >= 0489024000 = base + 14+ | base >= 0425865600 = base + 13+ | base >= 0394329600 = base + 12+ | base >= 0362793600 = base + 11+ | base >= 0315532800 = base + 10+ | base >= 0283996800 = base + 09+ | base >= 0252460800 = base + 08+ | base >= 0220924800 = base + 07+ | base >= 0189302400 = base + 06+ | base >= 0157766400 = base + 05+ | base >= 0126230400 = base + 04+ | base >= 0094694400 = base + 03+ | base >= 0078796800 = base + 02+ | base >= 0063072000 = base + 01+ | otherwise = base + 00++-- |+-- Convert UTC seconds into Unix and leap seconds.+baseUTCToUnix :: Int64 -> (Int64, Double)+baseUTCToUnix base+ | base >= 1483228828 = (base - 028, 0)+ | base == 1483228827 = (1483228799, 1)+ | base >= 1435708827 = (base - 027, 0)+ | base == 1435708826 = (1435708799, 1)+ | base >= 1341100826 = (base - 026, 0)+ | base == 1341100825 = (1341100799, 1)+ | base >= 1230768025 = (base - 025, 0)+ | base == 1230768024 = (1230767999, 1)+ | base >= 1136073624 = (base - 024, 0)+ | base == 1136073623 = (1136073599, 1)+ | base >= 0915148823 = (base - 023, 0)+ | base == 0915148822 = (0915148799, 1)+ | base >= 0867715222 = (base - 022, 0)+ | base == 0867715221 = (0867715199, 1)+ | base >= 0820454421 = (base - 021, 0)+ | base == 0820454420 = (0820454399, 1)+ | base >= 0773020820 = (base - 020, 0)+ | base == 0773020819 = (0773020799, 1)+ | base >= 0741484819 = (base - 019, 0)+ | base == 0741484818 = (0741484799, 1)+ | base >= 0709948818 = (base - 018, 0)+ | base == 0709948817 = (0709948799, 1)+ | base >= 0662688017 = (base - 017, 0)+ | base == 0662688016 = (0662687999, 1)+ | base >= 0631152016 = (base - 016, 0)+ | base == 0631152015 = (0631151999, 1)+ | base >= 0567993615 = (base - 015, 0)+ | base == 0567993614 = (0567993599, 1)+ | base >= 0489024014 = (base - 014, 0)+ | base == 0489024013 = (0489023999, 1)+ | base >= 0425865613 = (base - 013, 0)+ | base == 0425865612 = (0425865599, 1)+ | base >= 0394329612 = (base - 012, 0)+ | base == 0394329611 = (0394329599, 1)+ | base >= 0362793611 = (base - 011, 0)+ | base == 0362793610 = (0362793599, 1)+ | base >= 0315532810 = (base - 010, 0)+ | base == 0315532809 = (0315532799, 1)+ | base >= 0283996809 = (base - 009, 0)+ | base == 0283996808 = (0283996799, 1)+ | base >= 0252460808 = (base - 008, 0)+ | base == 0252460807 = (0252460799, 1)+ | base >= 0220924807 = (base - 007, 0)+ | base == 0220924806 = (0220924799, 1)+ | base >= 0189302406 = (base - 006, 0)+ | base == 0189302405 = (0189302399, 1)+ | base >= 0157766405 = (base - 005, 0)+ | base == 0157766404 = (0157766399, 1)+ | base >= 0126230404 = (base - 004, 0)+ | base == 0126230403 = (0126230399, 1)+ | base >= 0094694403 = (base - 003, 0)+ | base == 0094694402 = (0094694399, 1)+ | base >= 0078796802 = (base - 002, 0)+ | base == 0078796801 = (0078796799, 1)+ | base >= 0063072001 = (base - 001, 0)+ | base == 0063072000 = (0063071999, 1)+ | otherwise = (base - 000, 0)++-- |+-- Show the 12-hour pariod (ante or post meridiem) of the given 24-hour hour without performing any bounds check.+getPeriod :: Hour -> (String, Hour)+getPeriod hour+ | hour == 00 = ("AM", 12)+ | hour <= 11 = ("AM", hour)+ | hour == 12 = ("PM", hour)+ | otherwise = ("PM", hour - 12)
+ Foreign/C/Time.hsc view
@@ -0,0 +1,76 @@+-- |+-- Module : Foreign.C.Time+-- Copyright : 2013-2016 Enzo Haussecker+-- License : BSD3+-- Maintainer : Enzo Haussecker <enzo@sovereign.io>+-- Stability : Stable+--+-- High-level bindings to the C standard time library.++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS -fno-warn-orphans #-}+{-# OPTIONS -fno-warn-unused-binds #-}++module Foreign.C.Time (++ -- * Types+ C'timeval(..)+ , C'tm(..)++ -- * Re-Exports+ , CTime(..)++ -- * System Clock+ , getTimeOfDay++ ) where++import Data.Time.Exts.Base (Human(..))+import Foreign.C.String (CString)+import Foreign.C.Types (CInt(..), CLong, CTime(..))+import Foreign.Marshal.Alloc (alloca)+import Foreign.Marshal.Unsafe (unsafeLocalState)+import Foreign.Marshal.Utils (with)+import Foreign.Ptr (FunPtr, Ptr, nullPtr, plusPtr)+import Foreign.Storable (Storable(..))++#include <bindings.dsl.h>+#include <time.h>+#include <sys/time.h>++#starttype struct tm+#field tm_sec, CInt+#field tm_min, CInt+#field tm_hour, CInt+#field tm_mday, CInt+#field tm_mon, CInt+#field tm_year, CInt+#field tm_wday, CInt+#field tm_yday, CInt+#field tm_isdst, CInt+#field tm_gmtoff, CLong+#field tm_zone, CString+#stoptype++#starttype struct timeval+#field tv_sec, CLong+#field tv_usec, CLong+#stoptype++#ccall timegm, Ptr <tm> -> IO CTime+#ccall gmtime_r, Ptr CTime -> Ptr <tm> -> IO (Ptr <tm>)+#ccall gettimeofday, Ptr <timeval> -> Ptr () -> IO CInt++instance Human CTime where+ type Components CTime = C'tm+ pack = unsafeLocalState . flip with c'timegm+ unpack = unsafeLocalState . flip with f+ where f x = alloca $ \ ptr -> c'gmtime_r x ptr >>= peek++-- |+-- Get the current time from the system clock.+getTimeOfDay :: IO C'timeval+getTimeOfDay = with (C'timeval 0 0) $ \ ptr -> c'gettimeofday ptr nullPtr >>= getResult ptr+ where getResult ptr = \ case 0 -> peek ptr; n -> error $ "getTimeOfDay: " ++ show n
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014, Enzo Haussecker. All rights reserved. +Copyright (c) 2013-2016 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:
+ README.org view
@@ -0,0 +1,2 @@+#+TITLE: Yet Another Haskell Time Library+[[https://travis-ci.org/enzoh/time-exts][https://api.travis-ci.org/enzoh/time-exts.svg?branch=master]] [[https://hackage.haskell.org/package/time-exts][https://img.shields.io/hackage/v/time-exts.svg]] [[http://packdeps.haskellers.com/feed?needle=time-exts][https://img.shields.io/hackage-deps/v/time-exts.svg]]
+ Test.hs view
@@ -0,0 +1,404 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{-# OPTIONS -fno-warn-type-defaults #-}+{-# OPTIONS -fno-warn-orphans #-}++module Main where++import Control.Arrow (arr)+import Data.Char (toLower)+import Data.Int (Int64)+import Data.Time.LocalTime (TimeZone(..), utc)+import Data.Time.Zones (TZ, loadTZFromDB)+import Numeric.IEEE (epsilon)+import System.Exit (ExitCode(..), exitWith)+import System.Locale (defaultTimeLocale)+import Test.HUnit (Counts(..), Test(..), assertBool, assertEqual, runTestTT)+import Test.QuickCheck (Arbitrary(..), choose, sample')+import Text.Printf (printf)++import qualified Data.Text as Text (pack)++import Data.Time.Exts.Base+import Data.Time.Exts.Format+import Data.Time.Exts.Parser+import Data.Time.Exts.Unix+import Data.Time.Exts.Util+import Foreign.C.Time++instance Arbitrary Year where+ arbitrary = Year <$> choose (1970, 9999)++instance Arbitrary Day where+ arbitrary = Day <$> choose (1, 31)++instance Arbitrary Hour where+ arbitrary = Hour <$> choose (0, 23)++instance Arbitrary Minute where+ arbitrary = Minute <$> choose (0, 59)++instance Arbitrary Second where+ arbitrary = Second <$> choose (0, 59)++instance Arbitrary Millis where+ arbitrary = Millis <$> choose (0, 999)++instance Arbitrary Micros where+ arbitrary = Micros <$> choose (0, 999999)++instance Arbitrary Nanos where+ arbitrary = Nanos <$> choose (0, 999999999)++instance Arbitrary (Month 'Gregorian) where+ arbitrary = toEnum <$> choose (jan, dec)+ where jan = fromEnum (minBound :: DayOfWeek 'Gregorian)+ dec = fromEnum (maxBound :: DayOfWeek 'Gregorian)++instance Arbitrary (DayOfWeek 'Gregorian) where+ arbitrary = toEnum <$> choose (sun, sat)+ where sun = fromEnum (minBound :: DayOfWeek 'Gregorian)+ sat = fromEnum (maxBound :: DayOfWeek 'Gregorian)++instance Arbitrary (UnixDate 'Gregorian) where+ arbitrary = choose (minBound, maxBound)++instance Arbitrary (UnixDateTime 'Gregorian) where+ arbitrary = choose (minBound, maxBound)++instance Arbitrary (UnixDateTimeNanos 'Gregorian) where+ arbitrary = choose (minBound, maxBound)++withArbitraryInput+ :: Arbitrary a+ => (a -> Test)+ -> IO Test+withArbitraryInput f = TestList . map f <$> sample' arbitrary++test_properFracMillis :: Test+test_properFracMillis = TestList+ [+ TestCase . assertEqual "properFracMillis 0.33333333333333" (0, 000000000333) $ properFracMillis 0.33333333333333,+ TestCase . assertEqual "properFracMillis 0.66666666666666" (0, 000000000667) $ properFracMillis 0.66666666666666,+ TestCase . assertEqual "properFracMillis 0.99999999999999" (1, 000000000000) $ properFracMillis 0.99999999999999+ ]++test_properFracMicros :: Test+test_properFracMicros = TestList+ [+ TestCase . assertEqual "properFracMicros 0.33333333333333" (0, 000000333333) $ properFracMicros 0.33333333333333,+ TestCase . assertEqual "properFracMicros 0.66666666666666" (0, 000000666667) $ properFracMicros 0.66666666666666,+ TestCase . assertEqual "properFracMicros 0.99999999999999" (1, 000000000000) $ properFracMicros 0.99999999999999+ ]++test_properFracNanos :: Test+test_properFracNanos = TestList+ [+ TestCase . assertEqual "properFracNanos 0.33333333333333" (0, 000333333333) $ properFracNanos 0.33333333333333,+ TestCase . assertEqual "properFracNanos 0.66666666666666" (0, 000666666667) $ properFracNanos 0.66666666666666,+ TestCase . assertEqual "properFracNanos 0.99999999999999" (1, 000000000000) $ properFracNanos 0.99999999999999+ ]++test_properFracPicos :: Test+test_properFracPicos = TestList+ [+ TestCase . assertEqual "properFracPicos 0.33333333333333" (0, 333333333333) $ properFracPicos 0.33333333333333,+ TestCase . assertEqual "properFracPicos 0.66666666666666" (0, 666666666667) $ properFracPicos 0.66666666666666,+ TestCase . assertEqual "properFracPicos 0.99999999999999" (1, 000000000000) $ properFracPicos 0.99999999999999+ ]++parse+ :: (ParserState 'Gregorian -> Test)+ -> Maybe TZ+ -> Format+ -> String+ -> Test+parse test mtz formet input =+ either error test . runParser defaultTimeLocale mtz state formet $ Text.pack input+ where state = ParserState 1970 January 1 Thursday 0 0 0.0 id id (const (return utc))++deltaZero :: Double -> (Double -> Bool)+deltaZero x = (>) epsilon . abs . (-) x++test_parseYear :: Year -> Test+test_parseYear year =+ parse test Nothing "%Y" input+ where input = printf "%d" year+ err = printf "test_parseYear: \"%s\"" input+ test = TestCase . assertEqual err year . _ps_year++test_parseYear' :: Year -> Test+test_parseYear' year =+ parse test Nothing "%y" input+ where year' = mod year 100+ fix x = if x >= 2000 then x - 2000 else x - 1900+ input = printf "%02d" year'+ err = printf "test_parseYear': \"%s\"" input+ test = TestCase . assertEqual err year' . fix . _ps_year++test_parseMonth :: Month 'Gregorian -> Test+test_parseMonth month =+ parse test Nothing "%B" input+ where input = show month+ err = printf "test_parseMonth: \"%s\"" input+ test = TestCase . assertEqual err month . _ps_mon++test_parseMonth' :: Month 'Gregorian -> Test+test_parseMonth' month =+ parse test Nothing "%b" input+ where input = take 3 $ show month+ err = printf "test_parseMonth': \"%s\"" input+ test = TestCase . assertEqual err month . _ps_mon++test_parseMonth'' :: Month 'Gregorian -> Test+test_parseMonth'' month =+ parse test Nothing "%h" input+ where input = take 3 $ show month+ err = printf "test_parseMonth'': \"%s\"" input+ test = TestCase . assertEqual err month . _ps_mon++test_parseMonth''' :: Month 'Gregorian -> Test+test_parseMonth''' month =+ parse test Nothing "%m" input+ where input = printf "%02d" $ fromEnum month+ err = printf "test_parseMonth''': \"%s\"" input+ test = TestCase . assertEqual err month . _ps_mon++test_parseDay :: Day -> Test+test_parseDay day =+ parse test Nothing "%d" input+ where input = printf "%02d" day+ err = printf "test_parseDay: \"%s\"" input+ test = TestCase . assertEqual err day . _ps_mday++test_parseDay' :: Day -> Test+test_parseDay' day =+ parse test Nothing "%e" input+ where input = printf "%2d" day+ err = printf "test_parseDay': \"%s\"" input+ test = TestCase . assertEqual err day . _ps_mday++test_parseDayOfWeek :: DayOfWeek 'Gregorian -> Test+test_parseDayOfWeek day =+ parse test Nothing "%A" input+ where input = show day+ err = printf "test_parseDayOfWeek: \"%s\"" input+ test = TestCase . assertEqual err day . _ps_wday++test_parseDayOfWeek' :: DayOfWeek 'Gregorian -> Test+test_parseDayOfWeek' day =+ parse test Nothing "%a" input+ where input = take 3 $ show day+ err = printf "test_parseDayOfWeek': \"%s\"" input+ test = TestCase . assertEqual err day . _ps_wday++test_parseHour :: Hour -> Test+test_parseHour hour =+ parse test Nothing "%H" input+ where input = printf "%02d" hour+ err = printf "test_parseHour: \"%s\"" input+ test = TestCase . assertEqual err hour . _ps_hour++test_parseHour' :: Hour -> Test+test_parseHour' hour =+ parse test Nothing "%I%p" input+ where (,) period hour' = getPeriod hour+ input = printf "%02d%s" hour' period+ err = printf "test_parseHour': \"%s\"" input+ test = TestCase . assertEqual err hour . \ ps -> (_ps_ampm ps) (_ps_hour ps)++test_parseHour'' :: Hour -> Test+test_parseHour'' hour =+ parse test Nothing "%l%P" input+ where (,) period hour' = getPeriod hour+ input = printf "%2d%s" hour' (map toLower period)+ err = printf "test_parseHour'': \"%s\"" input+ test = TestCase . assertEqual err hour . \ ps -> (_ps_ampm ps) (_ps_hour ps)++test_parseMinute :: Minute -> Test+test_parseMinute minute =+ parse test Nothing "%M" input+ where input = printf "%02d" minute+ err = printf "test_parseMinute: \"%s\"" input+ test = TestCase . assertEqual err minute . _ps_min++test_parseSecond :: Second -> Test+test_parseSecond second =+ parse test Nothing "%S" input+ where input = printf "%02d" second+ err = printf "test_parseSecond: \"%s\"" input+ test = TestCase . assertEqual err second . truncate . _ps_sec++test_parseMillis :: Millis -> Test+test_parseMillis millis =+ parse test Nothing "%S%f" input+ where frac = realToFrac millis / 1000 :: Double+ input = printf "%06.3f" frac+ err = printf "test_parseMillis: \"%s\"" input+ test = TestCase . assertBool err . deltaZero frac . flip arr 0 . _ps_frac++test_parseMicros :: Micros -> Test+test_parseMicros micros =+ parse test Nothing "%S%f" input+ where frac = realToFrac micros / 1000000 :: Double+ input = printf "%09.6f" frac+ err = printf "test_parseMicros: \"%s\"" input+ test = TestCase . assertBool err . deltaZero frac . flip arr 0 . _ps_frac++test_parseNanos :: Nanos -> Test+test_parseNanos nanos =+ parse test Nothing "%S%f" input+ where frac = realToFrac nanos / 1000000000 :: Double+ input = printf "%012.9f" frac+ err = printf "test_parseNanos: \"%s\"" input+ test = TestCase . assertBool err . deltaZero frac . flip arr 0 . _ps_frac++test_parseZone :: String -> Int64 -> TimeZone -> IO Test+test_parseZone region base tz = do+ tzdata <- Just <$> loadTZFromDB region+ return $! parse test tzdata "%Z" input+ where input = timeZoneName tz+ err = printf "test_parseZone: \"%s\"" input+ test = TestCase . assertEqual err (Right tz) . flip arr base . _ps_zone++test_EnumUnixDate :: UnixDate 'Gregorian -> Test+test_EnumUnixDate date =+ TestCase . assertEqual err date . toEnum $ fromEnum date+ where err = "test_EnumUnixDate: " ++ show date++test_EnumUnixDateTime :: UnixDateTime 'Gregorian -> Test+test_EnumUnixDateTime time =+ TestCase . assertEqual err time . toEnum $ fromEnum time+ where err = "test_EnumUnixDateTime: " ++ show time++test_HumanUnixDate :: UnixDate 'Gregorian -> Test+test_HumanUnixDate date =+ TestCase . assertEqual err date . pack $ unpack date+ where err = "test_HumanUnixDate: " ++ show date++test_HumanUnixDateTime :: UnixDateTime 'Gregorian -> Test+test_HumanUnixDateTime time =+ TestCase . assertEqual err time . pack $ unpack time+ where err = "test_HumanUnixDateTime: " ++ show time++test_HumanUnixDateTimeNanos :: UnixDateTimeNanos 'Gregorian -> Test+test_HumanUnixDateTimeNanos time =+ TestCase . assertEqual err time . pack $ unpack time+ where err = "test_HumanUnixDateTimeNanos: " ++ show time++test_HumanCTime :: UnixDateTime 'Gregorian -> Test+test_HumanCTime time =+ TestCase . assertBool err $+ toInteger (c'tm'tm_year + 1900) == toInteger _dt_year &&+ toInteger (c'tm'tm_mon + 0001) == toInteger (fromEnum _dt_mon) &&+ toInteger c'tm'tm_mday == toInteger _dt_mday &&+ toInteger (c'tm'tm_wday + 0001) == toInteger (fromEnum _dt_wday) &&+ toInteger c'tm'tm_hour == toInteger _dt_hour &&+ toInteger c'tm'tm_min == toInteger _dt_min &&+ toInteger c'tm'tm_sec == truncate _dt_sec+ where ctime :: CTime+ ctime = fromIntegral $ fromEnum time+ C'tm {..} = unpack ctime+ DateTimeStruct {..} = unpack time+ err = "test_HumanCTime: " ++ show time++test_MathUnixDate :: UnixDate 'Gregorian -> Test+test_MathUnixDate date =+ TestCase . assertEqual err minBound $+ date `plus` negate day+ where err = "test_MathUnixDate: " ++ show date+ day = fromIntegral $ fromEnum date :: Day++test_MathUnixDateTime :: UnixDateTime 'Gregorian -> Test+test_MathUnixDateTime time =+ TestCase . assertEqual err minBound $+ time `plus` negate day `plus` negate _dt_hour `plus` negate _dt_min `plus` negate sec+ where DateTimeStruct {..} = unpack time+ date = createUnixDate _dt_year _dt_mon _dt_mday+ err = "test_MathUnixDateTime: " ++ show time+ day = fromIntegral $ fromEnum date :: Day+ sec = round _dt_sec :: Second++test_MathUnixDateTimeNanos :: UnixDateTimeNanos 'Gregorian -> Test+test_MathUnixDateTimeNanos time =+ TestCase . assertEqual err minBound $+ time `plus` negate day `plus` negate _dt_hour `plus` negate _dt_min `plus` negate sec `plus` negate nsec+ where DateTimeStruct {..} = unpack time+ date = createUnixDate _dt_year _dt_mon _dt_mday+ err = "test_MathUnixDateTime: " ++ show time+ day = fromIntegral $ fromEnum date :: Day+ (,) sec nsec = properFracNanos _dt_sec++test_ShowUnixDate :: UnixDate 'Gregorian -> Test+test_ShowUnixDate date =+ TestCase . assertEqual err date . either error id .+ parseUnixDate defaultTimeLocale fmt . Text.pack $ show date+ where fmt = "%a %b %d %Y"+ err = "test_ShowUnixDate: " ++ show date++test_ShowUnixDateTime :: UnixDateTime 'Gregorian -> Test+test_ShowUnixDateTime time =+ TestCase . assertEqual err time . either error id .+ parseUnixDateTime defaultTimeLocale fmt . Text.pack $ show time+ where fmt = "%r %a %b %d %Y"+ err = "test_ShowUnixDateTime: " ++ show time++test_ShowUnixDateTimeNanos :: UnixDateTimeNanos 'Gregorian -> Test+test_ShowUnixDateTimeNanos time =+ TestCase . assertEqual err time . either error id .+ parseUnixDateTimeNanos defaultTimeLocale fmt . Text.pack $ show time+ where fmt = "%I:%M:%S%f %p %a %b %d %Y"+ err = "test_ShowUnixDateTimeNanos: " ++ show time++tests :: IO Test+tests = TestList <$> sequence+ [+ return test_properFracMillis,+ return test_properFracMicros,+ return test_properFracNanos,+ return test_properFracPicos,+ withArbitraryInput test_parseYear,+ withArbitraryInput test_parseYear',+ withArbitraryInput test_parseMonth,+ withArbitraryInput test_parseMonth',+ withArbitraryInput test_parseMonth'',+ withArbitraryInput test_parseMonth''',+ withArbitraryInput test_parseDay,+ withArbitraryInput test_parseDay',+ withArbitraryInput test_parseDayOfWeek,+ withArbitraryInput test_parseDayOfWeek',+ withArbitraryInput test_parseHour,+ withArbitraryInput test_parseHour',+ withArbitraryInput test_parseHour'',+ withArbitraryInput test_parseMinute,+ withArbitraryInput test_parseSecond,+ withArbitraryInput test_parseMillis,+ withArbitraryInput test_parseMicros,+ withArbitraryInput test_parseNanos,+ test_parseZone "America/Los_Angeles" 1457834399 (TimeZone (-480) False "PST"),+ test_parseZone "America/Los_Angeles" 1457838000 (TimeZone (-420) True "PDT"),+ test_parseZone "America/Los_Angeles" 1478397599 (TimeZone (-420) True "PDT"),+ test_parseZone "America/Los_Angeles" 1478394000 (TimeZone (-480) False "PST"),+ withArbitraryInput test_EnumUnixDate,+ withArbitraryInput test_EnumUnixDateTime,+ withArbitraryInput test_HumanUnixDate,+ withArbitraryInput test_HumanUnixDateTime,+ withArbitraryInput test_HumanUnixDateTimeNanos,+ withArbitraryInput test_HumanCTime,+ withArbitraryInput test_MathUnixDate,+ withArbitraryInput test_MathUnixDateTime,+ withArbitraryInput test_MathUnixDateTimeNanos,+ withArbitraryInput test_ShowUnixDate,+ withArbitraryInput test_ShowUnixDateTime,+ withArbitraryInput test_ShowUnixDateTimeNanos+ ]++main :: IO ()+main = do+ Counts {..} <- tests >>= runTestTT+ exitWith $ case failures + errors of+ 0 -> ExitSuccess+ _ -> ExitFailure 1
− src/Data/Time/Exts.hs
@@ -1,35 +0,0 @@------------------------------------------------------------------- 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-- -- ** Unix Timestamps- , module Data.Time.Exts.Unix-- -- ** UTC and Local Timestamps- , module Data.Time.Exts.Local-- -- ** Timestamp Parsers- , module Data.Time.Exts.Parser-- -- ** Locations and Time Zones- , module Data.Time.Exts.Zone-- -- ** Language Bindings- , module Data.Time.Exts.C-- ) where--import Data.Time.Exts.Base hiding (TimeZone)-import Data.Time.Exts.C-import Data.Time.Exts.Local-import Data.Time.Exts.Parser-import Data.Time.Exts.Unix-import Data.Time.Exts.Zone
− src/Data/Time/Exts/Base.hs
@@ -1,366 +0,0 @@------------------------------------------------------------------- Copyright (c) 2014, Enzo Haussecker. All rights reserved. --------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# OPTIONS -Wall #-}---- | Basic definitions, including type classes, datatypes and functions.-module Data.Time.Exts.Base (-- -- ** Classes- Date(..)- , Time(..)- , Zone(..)- , DateTime(..)- , DateZone(..)- , TimeZone(..)- , DateTimeZone(..)- , DateTimeMath(..)- , Duration(..)-- -- ** Structs- , DateStruct(..)- , TimeStruct(..)- , DateTimeStruct(..)- , DateZoneStruct(..)- , DateTimeZoneStruct(..)-- -- ** Components- , Year(..)- , Month(..)- , Day(..)- , DayOfWeek(..)- , Hour(..)- , Minute(..)- , Second(..)- , Millis(..)- , Micros(..)- , Nanos(..)- , Picos(..)-- -- ** Fractions- , properFracMillis- , properFracMicros- , properFracNanos- , properFracPicos-- -- ** Durations- , epochToDate- , epochToTime- , midnightToTime-- -- ** Utilities- , isLeapYear- , showPeriod- , showSuffix-- ) where--import Control.Arrow (first)-import Data.Aeson (FromJSON, ToJSON)-import Data.Int (Int32, Int64)-import qualified Data.Time.Exts.Zone as TZ (TimeZone)-import Data.Typeable (Typeable)-import GHC.Generics (Generic)-import Text.Printf (PrintfArg)-import System.Random (Random(..))--class Date d where-- -- | Compose a timestamp from date components.- fromDateStruct :: DateStruct -> d-- -- | Decompose a timestamp into date components.- toDateStruct :: d -> DateStruct--class Time t where-- -- | Compose a timestamp from time components.- fromTimeStruct :: TimeStruct -> t-- -- | Decompose a timestamp into time components.- toTimeStruct :: t -> TimeStruct--class Zone x where-- -- | Change the time zone of a timestamp.- toTimeZone :: x -> TZ.TimeZone -> x--class (Date dt, Time 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 Zone dz => DateZone dz where-- -- | Compose a timestamp from date and time zone components.- fromDateZoneStruct :: DateZoneStruct -> dz-- -- | Decompose a timestamp into date and time zone components.- toDateZoneStruct :: dz -> DateZoneStruct--class Zone tz => TimeZone tz where-- -- | Compose a timestamp from time and time zone components.- fromTimeZoneStruct :: TimeZoneStruct -> tz-- -- | Decompose a timestamp into time and time zone components.- toTimeZoneStruct :: tz -> TimeZoneStruct--class DateZone dtz => DateTimeZone dtz where-- -- | Compose a timestamp from date, time and time zone components.- fromDateTimeZoneStruct :: DateTimeZoneStruct -> dtz-- -- | Decompose a timestamp into date, time and time zone components.- toDateTimeZoneStruct :: dtz -> DateTimeZoneStruct--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---- | A struct with date components.-data DateStruct = DateStruct {- _d_year :: {-# UNPACK #-} !Year- , _d_mon :: !Month- , _d_mday :: {-# UNPACK #-} !Day- , _d_wday :: !DayOfWeek- } deriving (Eq,Generic,Ord,Show,Typeable)---- | A struct with time components.-data TimeStruct = TimeStruct {- _t_hour :: {-# UNPACK #-} !Hour- , _t_min :: {-# UNPACK #-} !Minute- , _t_sec :: {-# UNPACK #-} !Double- } deriving (Eq,Generic,Ord,Show,Typeable)---- | A struct with date and time components.-data DateTimeStruct = DateTimeStruct {- _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 and time zone components.-data DateZoneStruct = DateZoneStruct {- _dz_year :: {-# UNPACK #-} !Year- , _dz_mon :: !Month- , _dz_mday :: {-# UNPACK #-} !Day- , _dz_wday :: !DayOfWeek- , _dz_zone :: !TZ.TimeZone- } deriving (Eq,Generic,Ord,Show,Typeable)---- | A struct with time and time zone components.-data TimeZoneStruct = TimeZoneStruct {- _tz_hour :: {-# UNPACK #-} !Hour- , _tz_min :: {-# UNPACK #-} !Minute- , _tz_sec :: {-# UNPACK #-} !Double- , _tz_zone :: !TZ.TimeZone- } deriving (Eq,Generic,Ord,Show,Typeable)---- | A struct with date, time and time zone components.-data DateTimeZoneStruct = DateTimeZoneStruct {- _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 :: !TZ.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)---- | Month.-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)---- | Day of week.-data DayOfWeek =- Sunday- | Monday- | Tuesday- | Wednesday- | Thursday- | Friday- | Saturday- deriving (Eq,Enum,Generic,Ord,Show,Typeable)---- | Hour.-newtype Hour = Hour {getHour :: Int64}- deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)---- | Minute.-newtype Minute = Minute {getMinute :: Int64}- deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)---- | Second.-newtype Second = Second {getSecond :: Int64}- deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)---- | Millisecond.-newtype Millis = Millis {getMillis :: Int64}- deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)---- | Microsecond.-newtype Micros = Micros {getMicros :: Int64}- deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)---- | Nanosecond.-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)--instance FromJSON DateStruct-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)--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 DateTimeStruct-instance ToJSON DateZoneStruct-instance ToJSON DateTimeZoneStruct-instance ToJSON DayOfWeek-instance ToJSON Month---- | Decompose a floating point number into second and millisecond components.-properFracMillis :: Floating a => RealFrac a => a -> (Second, 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 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 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 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 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 year) =- Day $ (year - 1970) * 365 + (year - 1969) `div` 004 -- (year - 1901) `div` 100 + (year - 1601) `div` 400---- | Calculate the number of days that have--- elapsed between January 1st and the given month.-yearToMonth :: Month -> Bool -> Day-yearToMonth month leap =- if leap- then- 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 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 (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 minute second =- Second (days * 86400) + midnightToTime hour minute second- where days = fromIntegral $ epochToDate year month day---- | Calculate the number of seconds (excluding leap seconds)--- that have elapsed between midnight and the given time.-midnightToTime :: Hour -> Minute -> Second -> Second-midnightToTime (Hour hour) (Minute minute) (Second second) =- Second $ (hour * 3600) + (minute * 60) + second---- | Check if the given year is a leap year.-isLeapYear :: Year -> Bool-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
@@ -1,58 +0,0 @@---------------------------------------------------------------------------------- Copyright (c) 2014, Enzo Haussecker, Nathan Howell. All rights reserved. -----------------------------------------------------------------------------------{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS -Wall #-}---- | Haskell bindings to the C time library.-module Data.Time.Exts.C where--import Data.Convertible (Convertible(..))-import Foreign.C.String (CString)-import Foreign.C.Types (CInt(..), CLong, CTime(..))-import Foreign.Marshal.Alloc (alloca)-import Foreign.Marshal.Unsafe (unsafeLocalState)-import Foreign.Marshal.Utils (with)-import Foreign.Ptr (FunPtr, Ptr, nullPtr, plusPtr)-import Foreign.Storable (Storable(..))--#include <bindings.dsl.h>-#include <time.h>-#include <sys/time.h>--#starttype struct tm-#field tm_sec , CInt-#field tm_min , CInt-#field tm_hour , CInt-#field tm_mday , CInt-#field tm_mon , CInt-#field tm_year , CInt-#field tm_wday , CInt-#field tm_yday , CInt-#field tm_isdst , CInt-#field tm_gmtoff , CLong-#field tm_zone , CString-#stoptype--#starttype struct timeval-#field tv_sec , CLong-#field tv_usec , CLong-#stoptype--#ccall timegm , Ptr <tm> -> IO CTime-#ccall gmtime_r , Ptr CTime -> Ptr <tm> -> IO (Ptr <tm>)-#ccall gettimeofday , Ptr <timeval> -> Ptr () -> IO CInt--instance Convertible CTime C'tm where- safeConvert = Right . unsafeLocalState . flip with f- where f x = alloca $ \ ptr -> c'gmtime_r x ptr >>= peek--instance Convertible C'tm CTime where- safeConvert = Right . unsafeLocalState . flip with c'timegm---- | Get the current Unix date and time from the system clock.-getTimeOfDay :: IO C'timeval-getTimeOfDay = with (C'timeval 0 0) $ \ ptr -> c'gettimeofday ptr nullPtr >>= getResult ptr- where getResult ptr 0 = peek ptr- getResult _ err = error $ "getTimeOfDay: " ++ show err
− src/Data/Time/Exts/Local.hs
@@ -1,1283 +0,0 @@------------------------------------------------------------------- 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- , lastTransition-- -- ** Get Current Local Timestamps Using Preloaded Time Zone Transitions Times- , getCurrentLocalDate'- , getCurrentLocalDateTime'- , getCurrentLocalDateTimeMillis'- , getCurrentLocalDateTimeMicros'- , getCurrentLocalDateTimeNanos'- , getCurrentLocalDateTimePicos'-- -- ** Pretty Local Timestamps- , prettyLocalDate- , prettyLocalDateTime-- -- ** Base Conversions- , baseUnixToUTC- , baseUTCToUnix-- ) 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 Data.Time.Exts.Base-import Data.Time.Exts.Unix-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)--import qualified Data.Time.Calendar as Cal-import qualified Data.Time.Exts.Zone as TZ-import qualified Data.Time.LocalTime.TimeZone.Olson as Olson---- | 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 {- _ld_day_base :: {-# UNPACK #-} !Int32- , _ld_day_zone :: {-# UNPACK #-} !Word8- } deriving (Eq,Generic,Typeable)---- | Seconds since Unix epoch (including leap seconds).-data LocalDateTime = LocalDateTime {- _ldt_sec_base :: {-# UNPACK #-} !Int64- , _ldt_sec_zone :: {-# UNPACK #-} !Word8- } deriving (Eq,Generic,Typeable)---- | Milliseconds since Unix epoch (including leap seconds).-data LocalDateTimeMillis = LocalDateTimeMillis {- _ldt_mil_base :: {-# UNPACK #-} !Int64- , _ldt_mil_zone :: {-# UNPACK #-} !Word8- } deriving (Eq,Generic,Typeable)---- | Microseconds since Unix epoch (including leap seconds).-data LocalDateTimeMicros = LocalDateTimeMicros {- _ldt_mic_base :: {-# UNPACK #-} !Int64- , _ldt_mic_zone :: {-# UNPACK #-} !Word8- } deriving (Eq,Generic,Typeable)---- | Nanoseconds since Unix epoch (including leap seconds).-data LocalDateTimeNanos = LocalDateTimeNanos {- _ldt_nan_base :: {-# UNPACK #-} !Int64- , _ldt_nan_nano :: {-# UNPACK #-} !Int16- , _ldt_nan_zone :: {-# UNPACK #-} !Word8- } deriving (Eq,Generic,Typeable)---- | Picoseconds since Unix epoch (including leap seconds).-data LocalDateTimePicos = LocalDateTimePicos {- _ldt_pic_base :: {-# UNPACK #-} !Int64- , _ldt_pic_pico :: {-# UNPACK #-} !Int32- , _ldt_pic_zone :: {-# UNPACK #-} !Word8- } deriving (Eq,Generic,Typeable)---- | Time zone transition time.-newtype Transition = Transition {- unboxTrans :: LocalDateTime- } deriving (Eq,Generic,Typeable)--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 ) _ld_day_base- poke (plusPtr ptr $ off + 4) _ld_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 ) _ldt_sec_base- poke (plusPtr ptr $ off + 8) _ldt_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 ) _ldt_mil_base- poke (plusPtr ptr $ off + 8) _ldt_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 ) _ldt_mic_base- poke (plusPtr ptr $ off + 8) _ldt_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 ) _ldt_nan_base- poke (plusPtr ptr $ off + 08) _ldt_nan_nano- poke (plusPtr ptr $ off + 10) _ldt_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 ) _ldt_pic_base- poke (plusPtr ptr $ off + 08) _ldt_pic_pico- poke (plusPtr ptr $ off + 12) _ldt_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 0 0- maxBound = LocalDateTime 253402257624 maxzone--instance Bounded LocalDateTimeMillis where- minBound = LocalDateTimeMillis 0 0- maxBound = LocalDateTimeMillis 253402257624999 maxzone--instance Bounded LocalDateTimeMicros where- minBound = LocalDateTimeMicros 0 0- maxBound = LocalDateTimeMicros 253402257624999999 maxzone--instance Bounded LocalDateTimeNanos where- minBound = LocalDateTimeNanos 0 0 0- maxBound = LocalDateTimeNanos 253402257624999999 999 maxzone--instance Bounded LocalDateTimePicos where- minBound = LocalDateTimePicos 0 0 0- maxBound = LocalDateTimePicos 253402257624999999 999999 maxzone--instance Local LocalDate where- localBase = fromIntegral . get ld_day_base- localZone = get ld_day_zone--instance Local LocalDateTime where- localBase = get ldt_sec_base- localZone = get ldt_sec_zone--instance Local LocalDateTimeMillis where- localBase = get ldt_mil_base- localZone = get ldt_mil_zone--instance Local LocalDateTimeMicros where- localBase = get ldt_mic_base- localZone = get ldt_mic_zone--instance Local LocalDateTimeNanos where- localBase = get ldt_nan_base- localZone = get ldt_nan_zone--instance Local LocalDateTimePicos where- localBase = get ldt_pic_base- localZone = get ldt_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 ldt_nan_nano)--instance Ord LocalDateTimePicos where- compare = comparing localBase <> comparing (get ldt_pic_pico)--instance DateTimeMath LocalDate Day where- date `plus` Day day =- check "plus{LocalDate,Day}" $- modify ld_day_base (+ day) date--instance DateTimeMath LocalDateTime Second where- time `plus` Second second =- check "plus{LocalDateTime,Second}" $- modify ldt_sec_base (+ second) time--instance DateTimeMath LocalDateTimeMillis Second where- time `plus` Second second =- check "plus{LocalDateTimeMillis,Second}" $- modify ldt_mil_base (+ second * 1000) time--instance DateTimeMath LocalDateTimeMicros Second where- time `plus` Second second =- check "plus{LocalDateTimeMicros,Second}" $- modify ldt_mic_base (+ second * 1000000) time--instance DateTimeMath LocalDateTimeNanos Second where- time `plus` Second second =- check "plus{LocalDateTimeNanos,Second}" $- modify ldt_nan_base (+ second * 1000000) time--instance DateTimeMath LocalDateTimePicos Second where- time `plus` Second second =- check "plus{LocalDateTimePicos,Second}" $- modify ldt_pic_base (+ second * 1000000) time--instance DateTimeMath LocalDateTimeMillis Millis where- time `plus` Millis millis =- check "plus{LocalDateTimeMillis,Millis}" $- modify ldt_mil_base (+ millis) time--instance DateTimeMath LocalDateTimeMicros Millis where- time `plus` Millis millis =- check "plus{LocalDateTimeMicros,Millis}" $- modify ldt_mic_base (+ millis * 1000) time--instance DateTimeMath LocalDateTimeNanos Millis where- time `plus` Millis millis =- check "plus{LocalDateTimeNanos,Millis}" $- modify ldt_nan_base (+ millis * 1000) time--instance DateTimeMath LocalDateTimePicos Millis where- time `plus` Millis millis =- check "plus{LocalDateTimePicos,Millis}" $- modify ldt_pic_base (+ millis * 1000) time--instance DateTimeMath LocalDateTimeMicros Micros where- time `plus` Micros micros =- check "plus{LocalDateTimeMicros,Micros}" $- modify ldt_mic_base (+ micros) time--instance DateTimeMath LocalDateTimeNanos Micros where- time `plus` Micros micros =- check "plus{LocalDateTimeNanos,Micros}" $- modify ldt_nan_base (+ micros) time--instance DateTimeMath LocalDateTimePicos Micros where- time `plus` Micros micros =- check "plus{LocalDateTimePicos,Micros}" $- modify ldt_pic_base (+ micros) time--instance DateTimeMath LocalDateTimeNanos Nanos where- time `plus` Nanos nanos =- check "plus{UnixDateTimeNanos,Nanos}" .- modify ldt_nan_base (+ micros) $- set ldt_nan_nano nano time- where nsum = fromIntegral (get ldt_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 ldt_pic_base (+ micros) $- set ldt_pic_pico pico time- where psum = fromIntegral (get ldt_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 ldt_pic_base (+ micros) $- set ldt_pic_pico pico time- where psum = fromIntegral (get ldt_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 . doubleInt . flip divMod 1000- fromEnum LocalDate{..} = fromIntegral _ld_day_base * 1000 + fromIntegral _ld_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 . doubleInt . flip divMod 1000- fromEnum LocalDateTime{..} = fromIntegral _ldt_sec_base * 1000 + fromIntegral _ldt_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 . doubleInt . flip divMod 1000- fromEnum LocalDateTimeMillis{..} = fromIntegral _ldt_mil_base * 1000 + fromIntegral _ldt_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]---- | 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 -> TZ.TimeZone -> LocalDate-createLocalDate year month day zone =- check "createLocalDate" . LocalDate base $ tz2w8 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 -> TZ.TimeZone -> LocalDateTime-createLocalDateTime year month day hour minute (Second second) zone =- check "createLocalDateTime" . LocalDateTime base $ tz2w8 zone- where base = baseUnixToUTC (unix - offset) + second- Second unix = epochToTime year month day hour minute 0- offset = TZ.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 -> TZ.TimeZone -> LocalDateTimeMillis-createLocalDateTimeMillis year month day hour minute (Second second) (Millis millis) zone =- check "createLocalDateTimeMillis" . LocalDateTimeMillis base $ tz2w8 zone- where base = 1000 * (baseUnixToUTC (unix - offset) + second) + millis- Second unix = epochToTime year month day hour minute 0- offset = TZ.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 -> TZ.TimeZone -> LocalDateTimeMicros-createLocalDateTimeMicros year month day hour minute (Second second) (Micros micros) zone =- check "createLocalDateTimeMicros" . LocalDateTimeMicros base $ tz2w8 zone- where base = 1000000 * (baseUnixToUTC (unix - offset) + second) + micros- Second unix = epochToTime year month day hour minute 0- offset = TZ.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 -> TZ.TimeZone -> LocalDateTimeNanos-createLocalDateTimeNanos year month day hour minute (Second second) (Nanos nanos) zone =- check "createLocalDateTimeNanos" . LocalDateTimeNanos base nano $ tz2w8 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 = TZ.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 -> TZ.TimeZone -> LocalDateTimePicos-createLocalDateTimePicos year month day hour minute (Second second) (Picos picos) zone =- check "createLocalDateTimePicos" . LocalDateTimePicos base pico $ tz2w8 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 = TZ.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 _ld_day_base- zone = w82tz _ld_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 _ldt_sec_base- sec = _dt_sec + leap- offset = TZ.getUTCOffset zone :: Minute- zone = w82tz _ldt_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 _ldt_mil_base 0001000- sec = _dt_sec + leap + millis / 0001000- offset = TZ.getUTCOffset zone :: Minute- zone = w82tz _ldt_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 _ldt_mic_base 1000000- sec = _dt_sec + leap + micros / 1000000- offset = TZ.getUTCOffset zone :: Minute- zone = w82tz _ldt_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 _ldt_nan_base 1000000- sec = _dt_sec + leap + micros / 1000000 + realToFrac _ldt_nan_nano / 1000000000- offset = TZ.getUTCOffset zone :: Minute- zone = w82tz _ldt_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 _ldt_pic_base 1000000- sec = _dt_sec + leap + micros / 1000000 + realToFrac _ldt_pic_pico / 1000000000000- offset = TZ.getUTCOffset zone :: Minute- zone = w82tz _ldt_pic_zone---- | Decompose a local base (in seconds) into day and second components.-decompLocalBase :: (Int64, TZ.TimeZone) -> (Int32, DiffTime)-decompLocalBase = uncurry (flip f) . first (uncurry g . baseUTCToUnix)- where f x = first $ fromIntegral . flip div 86400 . (+ 60 * TZ.getUTCOffset x)- g x = (x, ) . fromIntegral . (+ mod x 86400) . truncate--instance Convertible LocalDateTime LocalDate where- safeConvert LocalDateTime{..} = Right $ LocalDate base _ldt_sec_zone- where base = fst $ decompLocalBase (_ldt_sec_base, w82tz _ldt_sec_zone)--instance Convertible LocalDateTimeMillis LocalDate where- safeConvert LocalDateTimeMillis{..} = Right $ LocalDate base _ldt_mil_zone- where base = fst (decompLocalBase (div _ldt_mil_base 0001000, w82tz _ldt_mil_zone))--instance Convertible LocalDateTimeMicros LocalDate where- safeConvert LocalDateTimeMicros{..} = Right $ LocalDate base _ldt_mic_zone- where base = fst (decompLocalBase (div _ldt_mic_base 1000000, w82tz _ldt_mic_zone))--instance Convertible LocalDateTimeNanos LocalDate where- safeConvert LocalDateTimeNanos{..} = Right $ LocalDate base _ldt_nan_zone- where base = fst (decompLocalBase (div _ldt_nan_base 1000000, w82tz _ldt_nan_zone))--instance Convertible LocalDateTimePicos LocalDate where- safeConvert LocalDateTimePicos{..} = Right $ LocalDate base _ldt_pic_zone- where base = fst (decompLocalBase (div _ldt_pic_base 1000000, w82tz _ldt_pic_zone))--instance Convertible LocalDate Cal.Day where- safeConvert = Right . Cal.ModifiedJulianDay . toInteger . (+ 40587) . _ld_day_base--instance Convertible LocalDateTime UTCTime where- safeConvert LocalDateTime{..} = Right $ UTCTime julian pico- where julian = Cal.ModifiedJulianDay $ toInteger day + 40587- (day, pico) = decompLocalBase (_ldt_sec_base, w82tz _ldt_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 $ _ldt_mil_base `divMod` 0001000- (day , pico ) = fmap (+ frac) $ decompLocalBase (base, w82tz _ldt_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 $ _ldt_mic_base `divMod` 1000000- (day , pico ) = fmap (+ frac) $ decompLocalBase (base, w82tz _ldt_mic_zone)--instance Convertible LocalDateTimeNanos UTCTime where- safeConvert LocalDateTimeNanos{..} = Right $ UTCTime julian pico- where julian = Cal.ModifiedJulianDay $ toInteger day + 40587- frac = micros / 1000000 + fromIntegral _ldt_nan_nano / 0001000000000- (base, micros) = fmap fromIntegral $ _ldt_nan_base `divMod` 1000000- (day , pico ) = fmap (+ frac) $ decompLocalBase (base, w82tz _ldt_nan_zone)--instance Convertible LocalDateTimePicos UTCTime where- safeConvert LocalDateTimePicos{..} = Right $ UTCTime julian pico- where julian = Cal.ModifiedJulianDay $ toInteger day + 40587- frac = micros / 1000000 + fromIntegral _ldt_pic_pico / 1000000000000- (base, micros) = fmap fromIntegral $ _ldt_pic_base `divMod` 1000000- (day , pico ) = fmap (+ frac) $ decompLocalBase (base, w82tz _ldt_pic_zone)--instance Convertible Cal.Day LocalDate where- safeConvert = Right . check "safeConvert{Data.Time.Calendar.Day,LocalDate}" .- flip LocalDate (tz2w8 TZ.utc) . fromInteger . (subtract 40587) . Cal.toModifiedJulianDay--instance Convertible UTCTime LocalDateTime where- safeConvert UTCTime{..} = Right . check "safeConvert{Data.Time.Clock.UTCTime,LocalDateTime}" $- LocalDateTime base (tz2w8 TZ.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 (tz2w8 TZ.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 (tz2w8 TZ.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 (tz2w8 TZ.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 (tz2w8 TZ.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 Zone LocalDate where- toTimeZone time = flip (set ld_day_zone) time . tz2w8--instance Zone LocalDateTime where- toTimeZone time = flip (set ldt_sec_zone) time . tz2w8--instance Zone LocalDateTimeMillis where- toTimeZone time = flip (set ldt_mil_zone) time . tz2w8--instance Zone LocalDateTimeMicros where- toTimeZone time = flip (set ldt_mic_zone) time . tz2w8--instance Zone LocalDateTimeNanos where- toTimeZone time = flip (set ldt_nan_zone) time . tz2w8--instance Zone LocalDateTimePicos where- toTimeZone time = flip (set ldt_pic_zone) time . tz2w8--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--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 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 $ TZ.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 $ TZ.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 $ TZ.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 $ TZ.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 $ TZ.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 $ TZ.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 :: TZ.City -> IO [Transition]-getTransitions city = do- let file = TZ.getOlsonFile city- Olson.OlsonData{..} <- Olson.getOlsonFromFile file- let ttimes = uniquetimes $ sortBy future2past olsonTransitions- return $! foldr (step olsonTypes) [] $ map last 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 = TZ.TimeZoneAbbr city tt_abbr- base = baseUnixToUTC $ fromIntegral transTime- zone = tz2w8 $ TZ.unabbreviate abbr---- | Get the last time zone transition time for the given city and time.-lastTransition :: (DateTime dt, Unix dt) => TZ.City -> dt -> IO (Maybe Transition)-lastTransition city time = do- ttimes <- getTransitions city- return $! listToMaybe $ dropWhile f ttimes- where base = baseUnixToUTC $ unixNorm time- f tt = localBase tt > base---- | Get the current local date from the system clock.------ > >>> getCurrentLocalDate London --- > 2013-11-03 GMT----getCurrentLocalDate :: TZ.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 :: TZ.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 _udt_sec_base- f tt = localBase tt > base- mval = listToMaybe $ dropWhile f ttimes- zone = maybe (tz2w8 TZ.utc) localZone mval- if maybe True (/= convert time) nextLeap- then return $! LocalDateTime base zone- else let leap = round (realToFrac (_udt_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 :: TZ.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 $ _udt_mil_base `divMod` 1000- f tt = localBase tt > seconds- mval = listToMaybe $ dropWhile f ttimes- zone = maybe (tz2w8 TZ.utc) localZone mval- base = seconds * 1000 + millis- if maybe True (/= convert time) nextLeap- then return $! LocalDateTimeMillis base zone- else let leap = round (realToFrac (_udt_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 :: TZ.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 $ _udt_mic_base `divMod` 1000000- f tt = localBase tt > seconds- mval = listToMaybe $ dropWhile f ttimes- zone = maybe (tz2w8 TZ.utc) localZone mval- base = seconds * 1000000 + micros- if maybe True (/= convert time) nextLeap- then return $! LocalDateTimeMicros base zone- else let leap = round (realToFrac (_udt_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 :: TZ.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 $ _udt_nan_base `divMod` 1000000- f tt = localBase tt > seconds- mval = listToMaybe $ dropWhile f ttimes- zone = maybe (tz2w8 TZ.utc) localZone mval- base = seconds * 1000000 + micros- if maybe True (/= convert time) nextLeap- then return $! LocalDateTimeNanos base _udt_nan_nano zone- else let leap = round (realToFrac (_udt_nan_base `mod` 86400) / 0.0000864 :: Double)- in return $! LocalDateTimeNanos base _udt_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 :: TZ.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 $ _udt_pic_base `divMod` 1000000- f tt = localBase tt > seconds- mval = listToMaybe $ dropWhile f ttimes- zone = maybe (tz2w8 TZ.utc) localZone mval- base = seconds * 1000000 + micros- if maybe True (/= convert time) nextLeap- then return $! LocalDateTimePicos base _udt_pic_pico zone- else let picos = round (realToFrac (_udt_pic_base `mod` 86400) / 0.0000000864 :: Double)- in return $! LocalDateTimePicos base _udt_pic_pico zone `plus` Picos picos---- | Convert a local date and time with nanosecond granularity into an integer.-fromNanos :: LocalDateTimeNanos -> Integer-fromNanos (LocalDateTimeNanos base nano _) = toInteger base * 1000 + toInteger nano---- | Convert an integer into a local date and time with nanosecond granularity.-toNanos :: Integer -> (Word8 -> LocalDateTimeNanos)-toNanos n = LocalDateTimeNanos base nano- where (base, nano) = doubleInt $ n `divMod` 1000---- | Convert a local date and time with picosecond granularity into an integer.-fromPicos :: LocalDateTimePicos -> Integer-fromPicos (LocalDateTimePicos base pico _) = toInteger base * 1000000 + toInteger pico---- | Convert an integer into a local date and time with picosecond granularity.-toPicos :: Integer -> (Word8 -> LocalDateTimePicos)-toPicos n = LocalDateTimePicos base pico- where (base, pico) = doubleInt $ 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 = fromNanos new - fromNanos old--instance Duration LocalDateTimePicos Nanos where- duration old new =- if res < toInteger (maxBound::Int64) then Nanos $ fromInteger res `div` 1000- else error "duration{LocalDateTimePicos,Nanos}: integer overflow"- where res = fromPicos new - fromPicos 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 = fromPicos new - fromPicos 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 ld_day_base a, get ld_day_base b) g of { (base, g' ) ->- case randomR (get ld_day_zone a, get ld_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 ldt_sec_base a, get ldt_sec_base b) g of { (base, g' ) ->- case randomR (get ldt_sec_zone a, get ldt_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 ldt_mil_base a, get ldt_mil_base b) g of { (base, g' ) ->- case randomR (get ldt_mil_zone a, get ldt_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 ldt_mic_base a, get ldt_mic_base b) g of { (base, g' ) ->- case randomR (get ldt_mic_zone a, get ldt_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'') -> (toNanos base zone, g'') } }- randomR (a,b) g =- case randomR (fromNanos a, fromNanos b) g of { (base, g' ) ->- case randomR (get ldt_nan_zone a, get ldt_nan_zone b) g' of { (zone, g'') -> (toNanos 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'') -> (toPicos base zone, g'') } }- randomR (a,b) g =- case randomR (fromPicos a, fromPicos b) g of { (base, g' ) ->- case randomR (get ldt_pic_zone a, get ldt_pic_zone b) g' of { (zone, g'') -> (toPicos base zone, g'') } }---- | 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 $ TZ.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 $ TZ.abbreviate _dtz_zone- ampm = showPeriod _dtz_hour- hour | _dtz_hour == 00 = 12- | _dtz_hour <= 12 = _dtz_hour- | otherwise = _dtz_hour - 12---- | Maximum enumerated time zone value.-maxzone :: Word8-maxzone = tz2w8 maxBound---- | Convert an integral type into a time zone.-w82tz :: Word8 -> TZ.TimeZone-w82tz = toEnum . fromIntegral---- | Convert a time zone into a numeric value.-tz2w8 :: TZ.TimeZone -> Word8-tz2w8 = 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.-doubleInt :: (Integral a, Integral b, Num c, Num d) => (a, b) -> (c, d)-doubleInt = fromIntegral *** fromIntegral
− src/Data/Time/Exts/Parser.hs
@@ -1,770 +0,0 @@------------------------------------------------------------------------------------ Copyright (c) 2014, Enzo Haussecker, Steve Severance. All rights reserved. -------------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UnicodeSyntax #-}-{-# OPTIONS -Wall #-}---- | Timestamp parsers and related utilities.-module Data.Time.Exts.Parser (-- -- ** Utilities- FormatText- , ParseError(..)-- -- ** Parse Unix Timestamps- , parseUnixDate- , parseUnixTime- , parseUnixTimeMillis- , parseUnixTimeMicros- , parseUnixTimeNanos- , parseUnixTimePicos- , parseUnixDateTime- , parseUnixDateTimeMillis- , parseUnixDateTimeMicros- , parseUnixDateTimeNanos- , parseUnixDateTimePicos-- -- ** Parse UTC and Local Timestamps- , parseLocalDate- , parseLocalDateTime- , parseLocalDateTimeMillis- , parseLocalDateTimeMicros- , parseLocalDateTimeNanos- , parseLocalDateTimePicos-- -- ** Parse Unix Timestamps With Parameters- , parseUnixDate'- , parseUnixTime'- , parseUnixTimeMillis'- , parseUnixTimeMicros'- , parseUnixTimeNanos'- , parseUnixTimePicos'- , parseUnixDateTime'- , parseUnixDateTimeMillis'- , parseUnixDateTimeMicros'- , parseUnixDateTimeNanos'- , parseUnixDateTimePicos'-- -- ** Parse UTC and Local Timestamps With Parameters- , parseLocalDate'- , parseLocalDateTime'- , parseLocalDateTimeMillis'- , parseLocalDateTimeMicros'- , parseLocalDateTimeNanos'- , parseLocalDateTimePicos'-- ) where--import Control.Applicative ((<|>), (<$>), (*>))-import Control.Arrow ((***))-import Control.Exception (Exception)-import Control.Monad-import Control.Monad.State.Strict (execState, State)-import Data.Attoparsec.Text as P hiding (decimal)-import Data.Convertible (Convertible(..), prettyConvertError)-import Data.Char (isAlpha)-import Data.Default (def)-import Data.Label ((:->), mkLabels)-import Data.Label.Monadic (puts, modify)-import Data.List as L (foldl', foldl1, map, zip)-import Data.String (IsString(..))-import Data.Text as T-import Data.Time.Exts.Base hiding (TimeZone)-import Data.Time.Exts.Local-import Data.Time.Exts.Unix-import Data.Time.Exts.Zone-import Data.Typeable (Typeable)-import System.Locale (TimeLocale(..))---- | The format string is composed of various %-codes, each--- representing time-related information described below.------ [@%%@] A literal '%' character.------ [@%A@] The full weekday name according to the current locale.------ [@%a@] The abbreviated weekday name according to the current locale.------ [@%B@] The full month name according to the current locale.------ [@%b@] The abbreviated month name according to the current locale.------ [@%D@] Equivalent to %m\/%d\/%y.------ [@%d@] The day of the month as a decimal number (range 01 to 31).------ [@%e@] Like %d, the day of the month as a decimal number, but a leading zero is replaced by a space.------ [@%F@] Equivalent to %Y-%m-%d (the ISO 8601 date format).------ [@%H@] The hour as a decimal number using a 24-hour clock (range 00 to 23).------ [@%h@] Equivalent to %b.------ [@%I@] The hour as a decimal number using a 12-hour clock (range 01 to 12).------ [@%l@] Like %I, the hour as a decimal number using a 12-hour clock, but a leading zero is replaced by a space.------ [@%M@] The minute as a decimal number (range 00 to 59).------ [@%m@] The month as a decimal number (range 01 to 12).------ [@%P@] Like %p, the period of the day according to the current locale, but lowercase.------ [@%p@] The period of the day according to the current locale.------ [@%Q@] The fraction of the second as a decimal number (range 0 to 999999999999).------ [@%R@] Equivalent to %H:%M.------ [@%r@] Equivalent to %I:%M:%S %p.------ [@%S@] The second as a decimal number (range 00 to 60).------ [@%T@] Equivalent to %H:%M:%S.------ [@%Y@] The year as a decimal number (range 1970 to 9999).------ [@%y@] The year as a decimal number without a century (range 00 to 99). ------ [@%Z@] The timezone abbreviation. -type FormatText = Text---- | Error handling type.-newtype ParseError = ParseError String deriving (Show,Typeable)--instance Exception ParseError--instance IsString ParseError where- fromString = ParseError---- | A struct with date, time, and time zone--- components, plus component modifiers.-data TZ = TZ {- _set_year :: Year- , _set_mon :: Month- , _set_mday :: Day- , _set_wday :: DayOfWeek- , _set_hour :: Hour- , _set_min :: Minute- , _set_sec :: Double- , _set_frac :: Double -> Double- , _set_ampm :: Hour -> Hour- , _set_zone :: TimeZone- }--mkLabels [''TZ]---- | Parse a Unix date.------ > >>> parseUnixDate "%A, %B %e, %Y" "Tuesday, March 4, 2014"--- > Right 2014-03-04----parseUnixDate :: FormatText -> Text -> Either ParseError UnixDate-parseUnixDate = parseUnixDate' def---- | Same as @parseUnixDate@, except takes an additional locale parameter.------ > >>> let german = defaultTimeLocale { wDays = [("Sonntag","So"),("Montag","Mo")...--- > >>> parseUnixDate' german "%A, %B %e, %Y" "Dienstag, März 4, 2014"--- > Right 2014-03-04----parseUnixDate' :: TimeLocale -> FormatText -> Text -> Either ParseError UnixDate-parseUnixDate' locale format text = fun <$> parseTimestamp locale Universal format text- where fun TZ{..} = createUnixDate _set_year _set_mon _set_mday---- | Parse a Unix time.------ > >>> parseUnixTime "%T" "15:32:19"--- > Right 15:32:19----parseUnixTime :: FormatText -> Text -> Either ParseError UnixTime-parseUnixTime = parseUnixTime' def---- | Same as @parseUnixTime@, except takes an additional locale parameter. ------ > >>> let albanian = defaultTimeLocale { wDays = [("e diel","Die"),("e hënë ","Hën")...--- > >>> parseUnixTime' albanian "%l:%M:%S %p" "12:28:47 PD"--- > Right 00:28:47----parseUnixTime' :: TimeLocale -> FormatText -> Text -> Either ParseError UnixTime-parseUnixTime' locale format text = fun <$> parseTimestamp locale Universal format text- where fun TZ{..} = createUnixTime hour _set_min sec- where hour = _set_ampm _set_hour- sec = truncate _set_sec---- | Parse a Unix time with millisecond granularity.------ > >>> parseUnixTimeMillis "%I:%M:%S.%Q %p" "09:41:09.313 PM"--- > Right 21:41:09.313----parseUnixTimeMillis :: FormatText -> Text -> Either ParseError UnixTimeMillis-parseUnixTimeMillis = parseUnixTimeMillis' def---- | Same as @parseUnixTimeMillis@, except takes an additional locale parameter.------ > >>> let urdu = defaultTimeLocale { wDays = [("پير","پير"),("اتوار","اتوار")...--- > >>> parseUnixTimeMillis' urdu "%l:%M:%S.%Q %p" " 3:12:47.624 ش"--- > Right 15:12:47.624----parseUnixTimeMillis' :: TimeLocale -> FormatText -> Text -> Either ParseError UnixTimeMillis-parseUnixTimeMillis' locale format text = fun <$> parseTimestamp locale Universal format text- where fun TZ{..} = createUnixTimeMillis hour _set_min sec mil- where hour = _set_ampm _set_hour- (,) sec mil = properFracMillis $ _set_frac _set_sec---- | Parse a Unix time with microsecond granularity.------ > >>> parseUnixTimeMicros "%R:%S.%Q" "03:15:50.513439"--- > Right 03:15:50.513439----parseUnixTimeMicros :: FormatText -> Text -> Either ParseError UnixTimeMicros-parseUnixTimeMicros = parseUnixTimeMicros' def---- | Same as @parseUnixTimeMicros@, except takes an additional locale parameter.------ > >>> let chinese = defaultTimeLocale { wDays = [("星期日","日"),("星期一","一")...--- > >>> parseUnixTimeMicros' chinese "%p%I:%M:%S.%Q" "下午11:46:18.130561"--- > Right 23:46:18.130561----parseUnixTimeMicros' :: TimeLocale -> FormatText -> Text -> Either ParseError UnixTimeMicros-parseUnixTimeMicros' locale format text = fun <$> parseTimestamp locale Universal format text- where fun TZ{..} = createUnixTimeMicros hour _set_min sec mic- where hour = _set_ampm _set_hour- (,) sec mic = properFracMicros $ _set_frac _set_sec---- | Parse a Unix time with nanosecond granularity.------ > >>> parseUnixTimeNanos "%l:%M:%S.%Q %P" " 1:27:44.001256754 pm"--- > Right 13:27:44.001256754----parseUnixTimeNanos :: FormatText -> Text -> Either ParseError UnixTimeNanos-parseUnixTimeNanos = parseUnixTimeNanos' def---- | Same as @parseUnixTimeNanos@, except takes an additional locale parameter.------ > >>> let swahili = defaultTimeLocale { wDays = [("Jumapili","J2"),("Jumatatu","J3")...--- > >>> parseUnixTimeNanos' swahili "%H:%M:%S.%Q %p" "12:05:50.547621324 asubuhi"--- > Right 00:05:50.547621324----parseUnixTimeNanos' :: TimeLocale -> FormatText -> Text -> Either ParseError UnixTimeNanos-parseUnixTimeNanos' locale format text = fun <$> parseTimestamp locale Universal format text- where fun TZ{..} = createUnixTimeNanos hour _set_min sec nan- where hour = _set_ampm _set_hour- (,) sec nan = properFracNanos $ _set_frac _set_sec---- | Parse a Unix time with picosecond granularity.------ > >>> parseUnixTimePicos "%T.%Q" "13:09:23.247795919586"--- > Right 13:09:23.247795919586----parseUnixTimePicos :: FormatText -> Text -> Either ParseError UnixTimePicos-parseUnixTimePicos = parseUnixTimePicos' def---- | Same as @parseUnixTimePicos@, except takes an additional locale parameter.------ > >>> let japanese = defaultTimeLocale { wDays = [("日曜日","日"),("月曜日","月")...--- > >>> parseUnixTimePicos' japanese "%I:%M:%S.%Q %p" "04:20:15.340563315063 午前"--- > Right 04:20:15.340563315063----parseUnixTimePicos' :: TimeLocale -> FormatText -> Text -> Either ParseError UnixTimePicos-parseUnixTimePicos' locale format text = fun <$> parseTimestamp locale Universal format text- where fun TZ{..} = createUnixTimePicos hour _set_min sec pic- where hour = _set_ampm _set_hour- (,) sec pic = properFracPicos $ _set_frac _set_sec---- | Parse a Unix date and time.------ > >>> parseUnixDateTime "%FT%TZ" "2014-02-27T11:31:20Z"--- > Right 2014-02-27 11:31:20----parseUnixDateTime :: FormatText -> Text -> Either ParseError UnixDateTime-parseUnixDateTime = parseUnixDateTime' def---- | Same as @parseUnixDateTime@, except takes an additional locale parameter.------ > >>> let somali = defaultTimeLocale { wDays = [("Axad","Axa"),("Isniin","Isn")...--- > >>> parseUnixDateTime' somali "%A, %B %e, %r %Y" "Salaaso, Bisha Saddexaad 11, 03:41:33 galabnimo 2014"--- > Right 2014-03-11 15:41:33----parseUnixDateTime' :: TimeLocale -> FormatText -> Text -> Either ParseError UnixDateTime-parseUnixDateTime' locale format text = fun <$> parseTimestamp locale Universal format text- where fun TZ{..} = createUnixDateTime _set_year _set_mon _set_mday hour _set_min sec- where hour = _set_ampm _set_hour- sec = truncate _set_sec---- | Parse a Unix date and time with millisecond granularity.------ > >>> parseUnixDateTimeMillis "%a %B %e %I:%M:%S.%Q %p %Y" "Wed March 5 06:53:04.475 PM 2014"--- > Right 2014-03-05 18:53:04.475----parseUnixDateTimeMillis :: FormatText -> Text -> Either ParseError UnixDateTimeMillis-parseUnixDateTimeMillis = parseUnixDateTimeMillis' def---- | Same as @parseUnixDateTimeMillis@, except takes an additional locale parameter.------ > >>> let turkish = defaultTimeLocale { wDays = [("Pazar","Paz"),("Pazartesi","Pzt")...--- > >>> parseUnixDateTimeMillis' turkish "%a %B %e %I:%M:%S.%Q %p %Y" "Prş Mart 13 07:22:54.324 ÖS 2014"--- > Right 2014-03-13 19:22:54.324----parseUnixDateTimeMillis' :: TimeLocale -> FormatText -> Text -> Either ParseError UnixDateTimeMillis-parseUnixDateTimeMillis' locale format text = fun <$> parseTimestamp locale Universal format text- where fun TZ{..} = createUnixDateTimeMillis _set_year _set_mon _set_mday hour _set_min sec mil- where hour = _set_ampm _set_hour- (,) sec mil = properFracMillis $ _set_frac _set_sec---- | Parse a Unix date and time with microsecond granularity.------ > >>> parseUnixDateTimeMicros "%D %T.%Q" "03/06/14 17:26:55.148415"--- > Right 2014-03-06 17:26:55.148415----parseUnixDateTimeMicros :: FormatText -> Text -> Either ParseError UnixDateTimeMicros-parseUnixDateTimeMicros = parseUnixDateTimeMicros' def---- | Same as @parseUnixDateTimeMicros@, except takes an additional locale parameter.------ > >>> let angika = defaultTimeLocale { wDays = [("रविवार","रवि"),("सोमवार","सोम")...--- > >>> parseUnixDateTimeMicros' angika "%A %d %B %Y %I:%M:%S.%Q %p" "शुक्रवार 07 मार्च 2014 07:10:50.283025 अपराह्न"--- > Right 2014-03-07 19:10:50.283025----parseUnixDateTimeMicros' :: TimeLocale -> FormatText -> Text -> Either ParseError UnixDateTimeMicros-parseUnixDateTimeMicros' locale format text = fun <$> parseTimestamp locale Universal format text- where fun TZ{..} = createUnixDateTimeMicros _set_year _set_mon _set_mday hour _set_min sec mic- where hour = _set_ampm _set_hour- (,) sec mic = properFracMicros $ _set_frac _set_sec---- | Parse a Unix date and time with nanosecond granularity.------ > >>> parseUnixDateTimeNanos "%d.%m.%Y %I:%M:%S.%Q %p" "18.03.2014 07:06:43.774295132 PM"--- > Right 2014-03-18 19:06:43.774295132----parseUnixDateTimeNanos :: FormatText -> Text -> Either ParseError UnixDateTimeNanos-parseUnixDateTimeNanos = parseUnixDateTimeNanos' def---- | Same as @parseUnixDateTimeNanos@, except takes an additional locale parameter.------ > >>> let russian = defaultTimeLocale { wDays = [("Воскресенье","Вс"),("Понедельник","Пн")...--- > >>> parseUnixDateTimeNanos' russian "%a %d %b %Y %T.%Q" "Ср 11 дек 2013 22:17:42.146648836"--- > Right 2013-12-11 22:17:42.146648836----parseUnixDateTimeNanos' :: TimeLocale -> FormatText -> Text -> Either ParseError UnixDateTimeNanos-parseUnixDateTimeNanos' locale format text = fun <$> parseTimestamp locale Universal format text- where fun TZ{..} = createUnixDateTimeNanos _set_year _set_mon _set_mday hour _set_min sec nan- where hour = _set_ampm _set_hour- (,) sec nan = properFracNanos $ _set_frac _set_sec---- | Parse a Unix date and time with picosecond granularity.------ > >>> parseUnixDateTimePicos "%FT%T.%QZ" "2014-03-03T17:58:15.916795765305Z"--- > Right 2014-03-03 17:58:15.916795765305----parseUnixDateTimePicos :: FormatText -> Text -> Either ParseError UnixDateTimePicos-parseUnixDateTimePicos = parseUnixDateTimePicos' def---- | Same as @parseUnixDateTimePicos@, except takes an additional locale parameter.------ > >>> let norwegian = defaultTimeLocale { wDays = [("søndag","sø."),("mandag","ma.")...--- > >>> parseUnixDateTimePicos' norwegian "%a %d. %b %Y kl. %H.%M.%S.%Q" "fr. 07. mars 2014 kl. 21.11.55.837472109433"--- > Right 2014-03-07 21:11:55.837472109433----parseUnixDateTimePicos' :: TimeLocale -> FormatText -> Text -> Either ParseError UnixDateTimePicos-parseUnixDateTimePicos' locale format text = fun <$> parseTimestamp locale Universal format text- where fun TZ{..} = createUnixDateTimePicos _set_year _set_mon _set_mday hour _set_min sec pic- where hour = _set_ampm _set_hour- (,) sec pic = properFracPicos $ _set_frac _set_sec---- | Parse a local date.------ > >>> parseLocalDate "%A, %B %e, %Y (%Z)" "Monday, March 17, 2014 (PST)"--- > Right 2014-03-17 PST----parseLocalDate :: FormatText -> Text -> Either ParseError LocalDate-parseLocalDate = parseLocalDate' def Universal---- | Same as @parseLocalDate@, except takes an additional locale and city parameter.------ > >>> parseLocalDate' defaultTimeLocale Kolkata "%A, %B %e, %Y (%Z)" "Monday, March 17, 2014 (IST)"--- > Right 2014-03-17 IST------ Note that the city parameter is required to distinguish between the India and Israel.-parseLocalDate' :: TimeLocale -> City -> FormatText -> Text -> Either ParseError LocalDate-parseLocalDate' locale city format text = fun <$> parseTimestamp locale city format text- where fun TZ{..} = createLocalDate _set_year _set_mon _set_mday _set_zone---- | Parse a local date and time.------ > >>> parseLocalDateTime "%a %b %e %H:%M:%S %Z %Y" "Fri Mar 14 09:29:53 EST 2014"--- > Right 2014-03-14 09:29:53 EST----parseLocalDateTime :: FormatText -> Text -> Either ParseError LocalDateTime-parseLocalDateTime = parseLocalDateTime' def Universal---- | Same as @parseLocalDateTime@, except takes an additional locale and city parameter.------ > >>> let french = defaultTimeLocale { wDays = [("dimanche","dim."),("lundi","lun.")...--- > >>> parseLocalDateTime' french Paris "%a %d %b %T %Z %Y" "ven. 07 mars 22:49:03 UTC 2014"--- > Right 2014-03-07 22:49:03 UTC----parseLocalDateTime' :: TimeLocale -> City -> FormatText -> Text -> Either ParseError LocalDateTime-parseLocalDateTime' locale city format text = fun <$> parseTimestamp locale city format text- where fun TZ{..} = createLocalDateTime _set_year _set_mon _set_mday hour _set_min sec _set_zone- where hour = _set_ampm _set_hour- sec = truncate _set_sec---- | Parse a local date and time with millisecond granularity.------ > >>> parseLocalDateTimeMillis "%B %e %Y %I:%M:%S.%Q %p %Z" "July 1 2012 01:59:60.215 AM EET"--- > Right 2012-07-01 01:59:60.215 EET------ Note that the timestamp in the example above corresponds to a leap second.-parseLocalDateTimeMillis :: FormatText -> Text -> Either ParseError LocalDateTimeMillis-parseLocalDateTimeMillis = parseLocalDateTimeMillis' def Universal---- | Same as @parseLocalDateTimeMillis@, except takes an additional locale and city parameter.------ > >>> parseLocalDateTimeMillis' defaultTimeLocale Chicago "%B %e %Y %I:%M:%S.%Q %p %Z" "July 13 2013 12:15:30.985 AM CDT"--- > Right 2013-07-13 00:15:30.985 CDT------ Note that the city parameter is required to distinguish between the United States and China.-parseLocalDateTimeMillis' :: TimeLocale -> City -> FormatText -> Text -> Either ParseError LocalDateTimeMillis-parseLocalDateTimeMillis' locale city format text = fun <$> parseTimestamp locale city format text- where fun TZ{..} = createLocalDateTimeMillis _set_year _set_mon _set_mday hour _set_min sec mil _set_zone- where hour = _set_ampm _set_hour- (,) sec mil = properFracMillis $ _set_frac _set_sec---- | Parse a local date and time with microsecond granularity.------ > >>> parseLocalDateTimeMicros "%F %T.%Q (%Z)" "2014-03-04 02:45:42.827495 (HKT)"--- > Right 2014-03-04 02:45:42.827495 HKT----parseLocalDateTimeMicros :: FormatText -> Text -> Either ParseError LocalDateTimeMicros-parseLocalDateTimeMicros = parseLocalDateTimeMicros' def Universal---- | Same as @parseLocalDateTimeMicros@, except takes an additional locale and city parameter.------ > >>> let spanish = defaultTimeLocale { wDays = [("domingo","dom"),("lunes","lun")...--- > >>> parseLocalDateTimeMicros' spanish Paris "%a %d %b %I:%M:%S.%Q %P %Y %Z" "dom 26 ene 04:27:16.743312 pm 2014 CET"--- > Right 2014-01-26 16:27:16.743312 CET----parseLocalDateTimeMicros' :: TimeLocale -> City -> FormatText -> Text -> Either ParseError LocalDateTimeMicros-parseLocalDateTimeMicros' locale city format text = fun <$> parseTimestamp locale city format text- where fun TZ{..} = createLocalDateTimeMicros _set_year _set_mon _set_mday hour _set_min sec mic _set_zone- where hour = _set_ampm _set_hour- (,) sec mic = properFracMicros $ _set_frac _set_sec---- | Parse a local date and time with nanosecond granularity.------ > >>> parseLocalDateTimeNanos "%b. %d, %T.%Q %Z %Y" "Mar. 09, 18:53:55.856423459 UTC 2014"--- > Right 2014-03-09 18:53:55.856423459 UTC----parseLocalDateTimeNanos :: FormatText -> Text -> Either ParseError LocalDateTimeNanos-parseLocalDateTimeNanos = parseLocalDateTimeNanos' def Universal---- | Same as @parseLocalDateTimeNanos@, except takes an additional locale and city parameter.------ > >>> let italian = defaultTimeLocale { wDays = [("domenica","dom"),("lunedì","lun")...--- > >>> parseLocalDateTimeNanos' italian Paris "%a %e %b %Y %T.%Q %Z" "sab 12 apr 2014 04:59:21.528207540 CEST"--- > Right 2014-04-12 04:59:21.528207540 CEST----parseLocalDateTimeNanos' :: TimeLocale -> City -> FormatText -> Text -> Either ParseError LocalDateTimeNanos-parseLocalDateTimeNanos' locale city format text = fun <$> parseTimestamp locale city format text- where fun TZ{..} = createLocalDateTimeNanos _set_year _set_mon _set_mday hour _set_min sec nan _set_zone- where hour = _set_ampm _set_hour- (,) sec nan = properFracNanos $ _set_frac _set_sec---- | Parse a local date and time with picosecond granularity.------ > >>> parseLocalDateTimePicos "%d.%m.%Y %T.%Q %Z" "09.04.2014 05:22:56.587234905781 SGT"--- > Right 2014-04-09 05:22:56.587234905781 SGT----parseLocalDateTimePicos :: FormatText -> Text -> Either ParseError LocalDateTimePicos-parseLocalDateTimePicos = parseLocalDateTimePicos' def Universal---- | Same as @parseLocalDateTimePicos@, except takes an additional locale and city parameter.------ > >>> parseLocalDateTimePicos' defaultTimeLocale Shanghai "%a %b %d %Y %T.%Q %Z" "Sat Mar 08 2014 22:51:47.264356423524 CST"--- > Right 2014-03-08 22:51:47.264356423524 CST------ Note that the city parameter is required to distinguish between the United States and China.-parseLocalDateTimePicos' :: TimeLocale -> City -> FormatText -> Text -> Either ParseError LocalDateTimePicos-parseLocalDateTimePicos' locale city format text = fun <$> parseTimestamp locale city format text- where fun TZ{..} = createLocalDateTimePicos _set_year _set_mon _set_mday hour _set_min sec pic _set_zone- where hour = _set_ampm _set_hour- (,) sec pic = properFracPicos $ _set_frac _set_sec---- | Initialize timestamp components.-initTZ :: TZ-initTZ = TZ 1970 January 1 Thursday 0 0 0.0 id id utc---- | Parse timestamp components.-parseTimestamp- :: TimeLocale- -> City- -> FormatText- -> Text- -> Either ParseError TZ-parseTimestamp locale city format text =- either left Right $ do- parser <- parseFormat locale city format- parseOnly parser text- where left = Left . ParseError---- | Parse format text.-parseFormat- :: TimeLocale- -> City- -> FormatText- -> Either String (Parser TZ)-parseFormat locale city =- fmap exec . parseOnly parser- where parser = many' $ createParser locale city- exec x = flip execState initTZ <$> sequence <$> sequence x---- | Create a format text parser.-createParser- :: TimeLocale- -> City- -> Parser (Parser (State TZ ()))-createParser locale city =- matchLit "%%"- <|> matchSet "%A" set_wday (weekLong locale)- <|> matchSet "%a" set_wday (weekShort locale)- <|> matchSet "%B" set_mon (monthLong locale)- <|> matchSet "%b" set_mon (monthShort locale)- <|> matchMDY "%D" set_year set_mon set_mday- <|> matchSet "%d" set_mday (fixInt 2)- <|> matchSet "%e" set_mday padIntTwo- <|> matchYMD "%F" set_year set_mon set_mday- <|> matchSet "%H" set_hour (fixInt 2)- <|> matchSet "%h" set_mon (monthShort locale)- <|> matchSet "%I" set_hour (fixInt 2)- <|> matchSet "%l" set_hour padIntTwo- <|> matchSet "%M" set_min (fixInt 2)- <|> matchSet "%m" set_mon monthInt- <|> matchSet "%P" set_ampm (period locale toLower)- <|> matchSet "%p" set_ampm (period locale id)- <|> matchSet "%Q" set_frac fraction- <|> matchHM "%R" set_hour set_min- <|> matchT12 "%r" set_hour set_min set_sec locale- <|> matchSet "%S" set_sec second- <|> matchHMS "%T" set_hour set_min set_sec- <|> matchSet "%Y" set_year (fixInt 4)- <|> matchSet "%y" set_year yearTwo- <|> matchSet "%Z" set_zone (timezone city)- <|> matchTxt---- | Match a percent literal.-matchLit- :: Text- -> Parser (Parser (State TZ ()))-matchLit code =- string code *>- return (char '%' *> return (return ()))---- | Match a percent code and update the field--- with the value returned by the parser.-matchSet - :: Text- -> (TZ :-> a)- -> Parser a- -> Parser (Parser (State TZ ()))-matchSet code field parser =- string code *> return (puts field <$> parser)---- | Match a year-month-day percent code and update--- the fields with the values returned by the parser.-matchYMD- :: Text- -> (TZ :-> Year )- -> (TZ :-> Month)- -> (TZ :-> Day )- -> Parser (Parser (State TZ ()))-matchYMD code _year _mon _day =- string code *> return parser where- parser = do- y <- fixInt 4; _ <- char '-'- m <- monthInt; _ <- char '-'- d <- fixInt 2- return $!- puts _year y *>- puts _mon m *>- puts _day d---- | Match a month-day-year percent code and update--- the fields with the values returned by the parser.-matchMDY- :: Text- -> (TZ :-> Year )- -> (TZ :-> Month)- -> (TZ :-> Day )- -> Parser (Parser (State TZ ()))-matchMDY code _year _mon _day =- string code *> return parser where- parser = do- m <- monthInt; _ <- char '/'- d <- fixInt 2; _ <- char '/'- y <- yearTwo- return $!- puts _year y *>- puts _mon m *>- puts _day d---- | Match a hour-minute percent code and update the--- fields with the values returned by the parser.-matchHM- :: Text- -> (TZ :-> Hour )- -> (TZ :-> Minute)- -> Parser (Parser (State TZ ()))-matchHM code _hour _min =- string code *> return parser where- parser = do- h <- fixInt 2; _ <- char ':'- m <- fixInt 2- return $!- puts _hour h *>- puts _min m---- | Match a hour-minute-second percent code and update--- the fields with the values returned by the parser.-matchHMS- :: Text- -> (TZ :-> Hour )- -> (TZ :-> Minute)- -> (TZ :-> Double)- -> Parser (Parser (State TZ ()))-matchHMS code _hour _min _sec =- string code *> return parser where- parser = do- h <- fixInt 2; _ <- char ':'- m <- fixInt 2; _ <- char ':'- s <- second- return $!- puts _hour h *>- puts _min m *>- puts _sec s---- | Match a hour-minute-second-period percent code and--- update the fields with the values returned by the parser.-matchT12- :: Text- -> (TZ :-> Hour )- -> (TZ :-> Minute)- -> (TZ :-> Double)- -> TimeLocale- -> Parser (Parser (State TZ ()))-matchT12 code _hour _min _sec locale =- string code *> return parser where- parser = do- h <- fixInt 2; _ <- char ':'- m <- fixInt 2; _ <- char ':'- s <- second ; _ <- char ' '- f <- period locale id- return $!- puts _hour h *>- puts _min m *>- puts _sec s *>- modify _hour f---- | Match any other character sequence.-matchTxt :: Parser (Parser (State TZ ()))-matchTxt = takeWhile1 (/='%') >>= return . \ src -> do- trg <- P.take $ T.length src- if src == trg then return (return ())- else fail "matchTxt: mismatch"---- | Parse an integral type of exactly @n@ digits.-fixInt :: Integral a => Int -> Parser a-fixInt n = do- s <- replicateM n digit- return $! fromIntegral $ L.foldl' step 0 s- where step a c = a * 10 + fromEnum c - 48---- | Parse an integral type of two digits--- or one digit preceded by a space.-padIntTwo :: Integral a => Parser a-padIntTwo = do- let f a b = a * 10 + b- liftM2 f getDigit getDigit- <|> do char ' ' >> getDigit- where getDigit = do- d <- digit- return $! fromIntegral $ fromEnum d - 48---- | Parse a year in two digit format.-yearTwo :: Parser Year-yearTwo = f <$> fixInt 2- where f y = if y <= 69 then 2000 + y else 1900 + y---- | Parse a month in two digit format.-monthInt :: Parser Month-monthInt = do- m <- fixInt 2- if 1 <= m && m <= 12- then return $! toEnum (m-1)- else fail $ "monthInt: out of bounds"---- | Parse a month in short text format.-monthShort :: TimeLocale -> Parser Month-monthShort = fromList . flip L.zip monthList . L.map (pack . snd) . months---- | Parse a month in long text format.-monthLong :: TimeLocale -> Parser Month-monthLong = fromList . flip L.zip monthList . L.map (pack . fst) . months---- | Parse a day of week in short text format.-weekShort :: TimeLocale -> Parser DayOfWeek-weekShort = fromList . flip L.zip weekList . L.map (pack . snd) . wDays---- | Parse a day of week in long text format. -weekLong :: TimeLocale -> Parser DayOfWeek-weekLong = fromList . flip L.zip weekList . L.map (pack . fst) . wDays---- | Parse a second in two digit format.-second :: Parser Double-second = (realToFrac :: Int -> Double) <$> fixInt 2---- | Parse a decimal in zero to twelve digit format.-fraction :: Parser (Double -> Double)-fraction = do- (,) n l <- foldM step (0,0) [1..12]- return $! (+ realToFrac n * 10 ** (- realToFrac l))- where step :: (Int, Int) -> Int -> Parser (Int, Int)- step acc@(n,_) l = option acc . try $ do- c <- digit- let n' = n * 10 + fromEnum c - 48- return $! (n', l)---- | Parse period symbols.-period :: TimeLocale -> (Text -> Text) -> Parser (Hour -> Hour)-period TimeLocale{amPm = (am, pm)} casify = fromList- [(toText am, \ case 12 -> 00; x -> x )- ,(toText pm, \ case 12 -> 12; x -> x + 12)]- where toText = casify . pack---- | Parse a time zone.-timezone :: City -> Parser TimeZone-timezone city = do- t <- takeWhile1 isAlpha- case safeConvert . TimeZoneAbbr city $ unpack t of- Left err -> fail $ prettyConvertError err- Right zone -> return $! zone---- | Create a parser from a list of key-value pairs.-fromList :: [(Text, a)] -> Parser a-fromList = L.foldl1 (<|>) . L.map (uncurry (*>) . (string *** return))---- | List of days of the week.-weekList :: [DayOfWeek]-weekList = [Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday]---- | List of months of the year.-monthList :: [Month]-monthList = [January, February, March, April, May, June, July, August, September, October, November, December]
− src/Data/Time/Exts/Test.hs
@@ -1,175 +0,0 @@------------------------------------------------------------------- Copyright (c) 2013, Enzo Haussecker. All rights reserved. --------------------------------------------------------------------{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS -Wall #-}-{-# OPTIONS -fno-warn-orphans #-}--module Main where--import Control.Monad-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 UnixTime where- arbitrary = choose (minBound, maxBound)--instance Arbitrary UnixTimeMillis where- arbitrary = choose (minBound, maxBound)--instance Arbitrary UnixTimeMicros where- arbitrary = choose (minBound, maxBound)--instance Arbitrary UnixTimeNanos where- arbitrary = choose (minBound, maxBound)--instance Arbitrary UnixTimePicos 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 `plus` Second 43200, maxBound)--instance Arbitrary LocalDateTimeMillis where- arbitrary = choose (minBound `plus` Second 43200, maxBound)--instance Arbitrary LocalDateTimeMicros where- arbitrary = choose (minBound `plus` Second 43200, maxBound)--instance Arbitrary LocalDateTimeNanos where- arbitrary = choose (minBound `plus` Second 43200, maxBound)--instance Arbitrary LocalDateTimePicos where- arbitrary = choose (minBound `plus` Second 43200, 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' = x `toTimeZone` 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' = x `toTimeZone` utc---- | Test Unix time struct conversions.-test8 :: (Eq x, Time x, Show x, Unix x) => x -> Bool-test8 x | x == fromTimeStruct (toTimeStruct x) = True- | otherwise = error $ "test8: " ++ show x---- | Test properties.-main :: IO ()-main = replicateM_ 100 $ 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)- quickCheck (test8 :: UnixTime -> Bool)- quickCheck (test8 :: UnixTimeMillis -> Bool)- quickCheck (test8 :: UnixTimeMicros -> Bool)- quickCheck (test8 :: UnixTimeNanos -> Bool)- quickCheck (test8 :: UnixTimePicos -> Bool)
− src/Data/Time/Exts/Unix.hs
@@ -1,1534 +0,0 @@------------------------------------------------------------------- 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(..)- , UnixTime(..)- , UnixTimeMillis(..)- , UnixTimeMicros(..)- , UnixTimeNanos(..)- , UnixTimePicos(..)- , UnixDateTime(..)- , UnixDateTimeMillis(..)- , UnixDateTimeMicros(..)- , UnixDateTimeNanos(..)- , UnixDateTimePicos(..)-- -- ** Create Unix Timestamps- , createUnixDate- , createUnixTime- , createUnixTimeMillis- , createUnixTimeMicros- , createUnixTimeNanos- , createUnixTimePicos- , createUnixDateTime- , createUnixDateTimeMillis- , createUnixDateTimeMicros- , createUnixDateTimeNanos- , createUnixDateTimePicos-- -- ** Get Current Unix Timestamps- , getCurrentUnixDate- , getCurrentUnixTime- , getCurrentUnixTimeMillis- , getCurrentUnixTimeMicros- , getCurrentUnixTimeNanos- , getCurrentUnixTimePicos- , getCurrentUnixDateTime- , getCurrentUnixDateTimeMillis- , getCurrentUnixDateTimeMicros- , getCurrentUnixDateTimeNanos- , getCurrentUnixDateTimePicos-- -- ** Pretty Unix Timestamps- , prettyUnixDate- , prettyUnixTime- , 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-- -- | Get the normalized base component of a Unix timestamp.- unixNorm :: u -> Int64---- | Days since Unix epoch.-newtype UnixDate = UnixDate {- _ud_day_base :: Int32- } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable)---- | Seconds since midnight (excluding leap seconds).-newtype UnixTime = UnixTime {- _ut_sec_base :: Int32- } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable)---- | Milliseconds since midnight (excluding leap seconds).-newtype UnixTimeMillis = UnixTimeMillis {- _ut_mil_base :: Int32- } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable)---- | Microseconds since midnight (excluding leap seconds).-newtype UnixTimeMicros = UnixTimeMicros {- _ut_mic_base :: Int64- } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable)---- | Nanoseconds since midnight (excluding leap seconds).-newtype UnixTimeNanos = UnixTimeNanos {- _ut_nan_base :: Int64- } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable)---- | Picoseconds since midnight (excluding leap seconds).-newtype UnixTimePicos = UnixTimePicos {- _ut_pic_base :: Int64- } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable)---- | Seconds since Unix epoch (excluding leap seconds).-newtype UnixDateTime = UnixDateTime {- _udt_sec_base :: Int64- } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable)---- | Milliseconds since Unix epoch (excluding leap seconds).-newtype UnixDateTimeMillis = UnixDateTimeMillis {- _udt_mil_base :: Int64- } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable)---- | Microseconds since Unix epoch (excluding leap seconds).-newtype UnixDateTimeMicros = UnixDateTimeMicros {- _udt_mic_base :: Int64- } deriving (Eq,FromJSON,Generic,NFData,Ord,Storable,ToJSON,Typeable)---- | Nanoseconds since Unix epoch (excluding leap seconds).-data UnixDateTimeNanos = UnixDateTimeNanos {- _udt_nan_base :: {-# UNPACK #-} !Int64- , _udt_nan_nano :: {-# UNPACK #-} !Int16- } deriving (Eq,Generic,Ord,Typeable)---- | Picoseconds since Unix epoch (excluding leap seconds).-data UnixDateTimePicos = UnixDateTimePicos {- _udt_pic_base :: {-# UNPACK #-} !Int64- , _udt_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 ) _udt_nan_base- poke (plusPtr ptr $ off + 8) _udt_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 ) _udt_pic_base- poke (plusPtr ptr $ off + 8) _udt_pic_pico--instance ToJSON UnixDateTimeNanos-instance ToJSON UnixDateTimePicos--mkLabels [ ''DateTimeStruct- , ''UnixDate- , ''UnixTime- , ''UnixTimeMillis- , ''UnixTimeMicros- , ''UnixTimeNanos- , ''UnixTimePicos- , ''UnixDateTime- , ''UnixDateTimeMillis- , ''UnixDateTimeMicros- , ''UnixDateTimeNanos- , ''UnixDateTimePicos- ]--instance Bounded UnixDate where- minBound = UnixDate 0- maxBound = UnixDate 2932896--instance Bounded UnixTime where- minBound = UnixTime 0- maxBound = UnixTime 86399--instance Bounded UnixTimeMillis where- minBound = UnixTimeMillis 0- maxBound = UnixTimeMillis 86399999--instance Bounded UnixTimeMicros where- minBound = UnixTimeMicros 0- maxBound = UnixTimeMicros 86399999999--instance Bounded UnixTimeNanos where- minBound = UnixTimeNanos 0- maxBound = UnixTimeNanos 86399999999999--instance Bounded UnixTimePicos where- minBound = UnixTimePicos 0- maxBound = UnixTimePicos 86399999999999999--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 ud_day_base- unixNorm = unixBase--instance Unix UnixTime where- unixBase = fromIntegral . get ut_sec_base- unixNorm = unixBase--instance Unix UnixTimeMillis where- unixBase = fromIntegral . get ut_mil_base- unixNorm = flip div 1000 . unixBase--instance Unix UnixTimeMicros where- unixBase = get ut_mic_base- unixNorm = flip div 1000000 . unixBase--instance Unix UnixTimeNanos where- unixBase = get ut_nan_base- unixNorm = flip div 1000000000 . unixBase--instance Unix UnixTimePicos where- unixBase = get ut_pic_base- unixNorm = flip div 1000000000000 . unixBase--instance Unix UnixDateTime where- unixBase = get udt_sec_base- unixNorm = unixBase--instance Unix UnixDateTimeMillis where- unixBase = get udt_mil_base- unixNorm = flip div 1000 . unixBase--instance Unix UnixDateTimeMicros where- unixBase = get udt_mic_base- unixNorm = flip div 1000000 . unixBase--instance Unix UnixDateTimeNanos where- unixBase = get udt_nan_base- unixNorm = flip div 1000000 . unixBase--instance Unix UnixDateTimePicos where- unixBase = get udt_pic_base- unixNorm = flip div 1000000 . unixBase--instance DateTimeMath UnixDate Day where- date `plus` Day day =- check "plus{UnixDate,Day}" $- modify ud_day_base (+ day) date--instance DateTimeMath UnixTime Hour where- time `plus` Hour hour =- check "plus{UnixTime,Hour}" $- modify ut_sec_base (+ fromIntegral hour * 3600) time--instance DateTimeMath UnixTime Minute where- time `plus` Minute minute =- check "plus{UnixTime,Minute}" $- modify ut_sec_base (+ fromIntegral minute * 60) time--instance DateTimeMath UnixTime Second where- time `plus` Second second =- check "plus{UnixTime,Second}" $- modify ut_sec_base (+ fromIntegral second) time--instance DateTimeMath UnixTimeMillis Hour where- time `plus` Hour hour =- check "plus{UnixTimeMillis,Hour}" $- modify ut_mil_base (+ fromIntegral hour * 3600000) time--instance DateTimeMath UnixTimeMillis Minute where- time `plus` Minute minute =- check "plus{UnixTimeMillis,Minute}" $- modify ut_mil_base (+ fromIntegral minute * 60000) time--instance DateTimeMath UnixTimeMillis Second where- time `plus` Second second =- check "plus{UnixTimeMillis,Second}" $- modify ut_mil_base (+ fromIntegral second * 1000) time--instance DateTimeMath UnixTimeMillis Millis where- time `plus` Millis millis =- check "plus{UnixTimeMillis,Millis}" $- modify ut_mil_base (+ fromIntegral millis) time--instance DateTimeMath UnixTimeMicros Hour where- time `plus` Hour hour =- check "plus{UnixTimeMicros,Hour}" $- modify ut_mic_base (+ hour * 3600000000) time--instance DateTimeMath UnixTimeMicros Minute where- time `plus` Minute minute =- check "plus{UnixTimeMicros,Minute}" $- modify ut_mic_base (+ minute * 60000000) time--instance DateTimeMath UnixTimeMicros Second where- time `plus` Second second =- check "plus{UnixTimeMicros,Second}" $- modify ut_mic_base (+ second * 1000000) time--instance DateTimeMath UnixTimeMicros Millis where- time `plus` Millis millis =- check "plus{UnixTimeMicros,Millis}" $- modify ut_mic_base (+ millis * 1000) time--instance DateTimeMath UnixTimeMicros Micros where- time `plus` Micros micros =- check "plus{UnixTimeMicros,Micros}" $- modify ut_mic_base (+ micros) time--instance DateTimeMath UnixTimeNanos Hour where- time `plus` Hour hour =- check "plus{UnixTimeNanos,Hour}" $- modify ut_nan_base (+ hour * 3600000000000) time--instance DateTimeMath UnixTimeNanos Minute where- time `plus` Minute minute =- check "plus{UnixTimeNanos,Minute}" $- modify ut_nan_base (+ minute * 60000000000) time--instance DateTimeMath UnixTimeNanos Second where- time `plus` Second second =- check "plus{UnixTimeNanos,Second}" $- modify ut_nan_base (+ second * 1000000000) time--instance DateTimeMath UnixTimeNanos Millis where- time `plus` Millis millis =- check "plus{UnixTimeNanos,Millis}" $- modify ut_nan_base (+ millis * 1000000) time--instance DateTimeMath UnixTimeNanos Micros where- time `plus` Micros micros =- check "plus{UnixTimeNanos,Micros}" $- modify ut_nan_base (+ micros * 1000) time--instance DateTimeMath UnixTimeNanos Nanos where- time `plus` Nanos nanos =- check "plus{UnixTimeNanos,Nanos}" $- modify ut_nan_base (+ nanos) time--instance DateTimeMath UnixTimePicos Hour where- time `plus` Hour hour =- check "plus{UnixTimePicos,Hour}" $- modify ut_pic_base (+ hour * 3600000000000000) time--instance DateTimeMath UnixTimePicos Minute where- time `plus` Minute minute =- check "plus{UnixTimePicos,Minute}" $- modify ut_pic_base (+ minute * 60000000000000) time--instance DateTimeMath UnixTimePicos Second where- time `plus` Second second =- check "plus{UnixTimePicos,Second}" $- modify ut_pic_base (+ second * 1000000000000) time--instance DateTimeMath UnixTimePicos Millis where- time `plus` Millis millis =- check "plus{UnixTimePicos,Millis}" $- modify ut_pic_base (+ millis * 1000000000) time--instance DateTimeMath UnixTimePicos Micros where- time `plus` Micros micros =- check "plus{UnixTimePicos,Micros}" $- modify ut_pic_base (+ micros * 1000000) time--instance DateTimeMath UnixTimePicos Nanos where- time `plus` Nanos nanos =- check "plus{UnixTimePicos,Nanos}" $- modify ut_pic_base (+ nanos * 1000) time--instance DateTimeMath UnixTimePicos Picos where- time `plus` Picos picos =- check "plus{UnixTimePicos,Picos}" $- modify ut_pic_base (+ picos) time--instance DateTimeMath UnixDateTime Day where- time `plus` Day day =- check "plus{UnixDateTime,Day}" $- modify udt_sec_base (+ fromIntegral day * 86400) time--instance DateTimeMath UnixDateTime Hour where- time `plus` Hour hour =- check "plus{UnixDateTime,Hour}" $- modify udt_sec_base (+ hour * 3600) time--instance DateTimeMath UnixDateTime Minute where- time `plus` Minute minute =- check "plus{UnixDateTime,Minute}" $- modify udt_sec_base (+ minute * 60) time--instance DateTimeMath UnixDateTime Second where- time `plus` Second second =- check "plus{UnixDateTime,Second}" $- modify udt_sec_base (+ second) time--instance DateTimeMath UnixDateTimeMillis Day where- time `plus` Day day =- check "plus{UnixDateTimeMillis,Day}" $- modify udt_mil_base (+ fromIntegral day * 86400000) time--instance DateTimeMath UnixDateTimeMillis Hour where- time `plus` Hour hour =- check "plus{UnixDateTimeMillis,Hour}" $- modify udt_mil_base (+ hour * 3600000) time--instance DateTimeMath UnixDateTimeMillis Minute where- time `plus` Minute minute =- check "plus{UnixDateTimeMillis,Minute}" $- modify udt_mil_base (+ minute * 60000) time--instance DateTimeMath UnixDateTimeMillis Second where- time `plus` Second second =- check "plus{UnixDateTimeMillis,Second}" $- modify udt_mil_base (+ second * 1000) time--instance DateTimeMath UnixDateTimeMillis Millis where- time `plus` Millis millis =- check "plus{UnixDateTimeMillis,Millis}" $- modify udt_mil_base (+ millis) time--instance DateTimeMath UnixDateTimeMicros Day where- time `plus` Day day =- check "plus{UnixDateTimeMicros,Day}" $- modify udt_mic_base (+ fromIntegral day * 86400000000) time--instance DateTimeMath UnixDateTimeMicros Hour where- time `plus` Hour hour =- check "plus{UnixDateTimeMicros,Hour}" $- modify udt_mic_base (+ hour * 3600000000) time--instance DateTimeMath UnixDateTimeMicros Minute where- time `plus` Minute minute =- check "plus{UnixDateTimeMicros,Minute}" $- modify udt_mic_base (+ minute * 60000000) time--instance DateTimeMath UnixDateTimeMicros Second where- time `plus` Second second =- check "plus{UnixDateTimeMicros,Second}" $- modify udt_mic_base (+ second * 1000000) time--instance DateTimeMath UnixDateTimeMicros Millis where- time `plus` Millis millis =- check "plus{UnixDateTimeMicros,Millis}" $- modify udt_mic_base (+ millis * 1000) time--instance DateTimeMath UnixDateTimeMicros Micros where- time `plus` Micros micros =- check "plus{UnixDateTimeMicros,Micros}" $- modify udt_mic_base (+ micros) time--instance DateTimeMath UnixDateTimeNanos Day where- time `plus` Day day =- check "plus{UnixDateTimeNanos,Day}" $- modify udt_nan_base (+ fromIntegral day * 86400000000) time--instance DateTimeMath UnixDateTimeNanos Hour where- time `plus` Hour hour =- check "plus{UnixDateTimeNanos,Hour}" $- modify udt_nan_base (+ hour * 3600000000) time--instance DateTimeMath UnixDateTimeNanos Minute where- time `plus` Minute minute =- check "plus{UnixDateTimeNanos,Minute}" $- modify udt_nan_base (+ minute * 60000000) time--instance DateTimeMath UnixDateTimeNanos Second where- time `plus` Second second =- check "plus{UnixDateTimeNanos,Second}" $- modify udt_nan_base (+ second * 1000000) time--instance DateTimeMath UnixDateTimeNanos Millis where- time `plus` Millis millis =- check "plus{UnixDateTimeNanos,Millis}" $- modify udt_nan_base (+ millis * 1000) time--instance DateTimeMath UnixDateTimeNanos Micros where- time `plus` Micros micros =- check "plus{UnixDateTimeNanos,Micros}" $- modify udt_nan_base (+ micros) time--instance DateTimeMath UnixDateTimeNanos Nanos where- UnixDateTimeNanos{..} `plus` Nanos nanos =- check "plus{UnixDateTimeNanos,Nanos}" .- uncurry UnixDateTimeNanos .- ((+ _udt_nan_base) *** fromIntegral) .- flip divMod 1000 $- fromIntegral _udt_nan_nano + nanos--instance DateTimeMath UnixDateTimePicos Day where- time `plus` Day day =- check "plus{UnixDateTimePicos,Day}" $- modify udt_pic_base (+ fromIntegral day * 86400000000) time--instance DateTimeMath UnixDateTimePicos Hour where- time `plus` Hour hour =- check "plus{UnixDateTimePicos,Hour}" $- modify udt_pic_base (+ hour * 3600000000) time--instance DateTimeMath UnixDateTimePicos Minute where- time `plus` Minute minute =- check "plus{UnixDateTimePicos,Minute}" $- modify udt_pic_base (+ minute * 60000000) time--instance DateTimeMath UnixDateTimePicos Second where- time `plus` Second second =- check "plus{UnixDateTimePicos,Second}" $- modify udt_pic_base (+ second * 1000000) time--instance DateTimeMath UnixDateTimePicos Millis where- time `plus` Millis millis =- check "plus{UnixDateTimePicos,Millis}" $- modify udt_pic_base (+ millis * 1000) time--instance DateTimeMath UnixDateTimePicos Micros where- time `plus` Micros micros =- check "plus{UnixDateTimePicos,Micros}" $- modify udt_pic_base (+ micros) time--instance DateTimeMath UnixDateTimePicos Nanos where- UnixDateTimePicos{..} `plus` Nanos nanos =- check "plus{UnixDateTimePicos,Nanos}" .- uncurry UnixDateTimePicos .- ((+ _udt_pic_base) *** fromIntegral) .- flip divMod 1000000 $- fromIntegral _udt_pic_pico + nanos * 1000--instance DateTimeMath UnixDateTimePicos Picos where- UnixDateTimePicos{..} `plus` Picos picos =- check "plus{UnixDateTimePicos,Picos}" .- uncurry UnixDateTimePicos .- ((+ _udt_pic_base) *** fromIntegral) .- flip divMod 1000000 $- fromIntegral _udt_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 . _ud_day_base--instance Enum UnixTime where- succ = flip plus $ Second 1- pred = flip plus . Second $ - 1- toEnum = check "toEnum{UnixTime}" . UnixTime . fromIntegral- fromEnum = fromIntegral . _ut_sec_base--instance Enum UnixTimeMillis where- succ = flip plus $ Millis 1- pred = flip plus . Millis $ - 1- toEnum = check "toEnum{UnixTimeMillis}" . UnixTimeMillis . fromIntegral- fromEnum = fromIntegral . _ut_mil_base--instance Enum UnixTimeMicros where- succ = flip plus $ Micros 1- pred = flip plus . Micros $ - 1- toEnum = check "toEnum{UnixTimeMicros}" . UnixTimeMicros . fromIntegral- fromEnum = fromIntegral . _ut_mic_base--instance Enum UnixTimeNanos where- succ = flip plus $ Nanos 1- pred = flip plus . Nanos $ - 1- toEnum = check "toEnum{UnixTimeNanos}" . UnixTimeNanos . fromIntegral- fromEnum = fromIntegral . _ut_nan_base--instance Enum UnixTimePicos where- succ = flip plus $ Picos 1- pred = flip plus . Picos $ - 1- toEnum = check "toEnum{UnixTimePicos}" . UnixTimePicos . fromIntegral- fromEnum = fromIntegral . _ut_pic_base--instance Enum UnixDateTime where- succ = flip plus $ Second 1- pred = flip plus . Second $ - 1- toEnum = check "toEnum{UnixDateTime}" . UnixDateTime . fromIntegral- fromEnum = fromIntegral . _udt_sec_base--instance Enum UnixDateTimeMillis where- succ = flip plus $ Millis 1- pred = flip plus . Millis $ - 1- toEnum = check "toEnum{UnixDateTimeMillis}" . UnixDateTimeMillis . fromIntegral- fromEnum = fromIntegral . _udt_mil_base--instance Enum UnixDateTimeMicros where- succ = flip plus $ Micros 1- pred = flip plus . Micros $ - 1- toEnum = check "toEnum{UnixDateTimeMicros}" . UnixDateTimeMicros . fromIntegral- fromEnum = fromIntegral . _udt_mic_base---- | Create a Unix date.------ > >>> createUnixDate 2013 November 3--- > 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 time.------ > >>> createUnixTime 4 52 7--- > 04:52:07----createUnixTime :: Hour -> Minute -> Second -> UnixTime-createUnixTime hour minute second =- check "createUnixTime" $ UnixTime base- where base = fromIntegral $ midnightToTime hour minute second---- | Create a Unix time with millisecond granularity.------ > >>> createUnixTimeMillis 15 22 47 2--- > 15:22:47.002----createUnixTimeMillis :: Hour -> Minute -> Second -> Millis -> UnixTimeMillis-createUnixTimeMillis hour minute second (Millis millis) =- check "createUnixTimeMillis" $ UnixTimeMillis base- where Second seconds = midnightToTime hour minute second- base = fromIntegral seconds * 1000 + fromIntegral millis---- | Create a Unix time with microsecond granularity.------ > >>> createUnixTimeMicros 10 6 33 575630--- > 10:06:33.575630----createUnixTimeMicros :: Hour -> Minute -> Second -> Micros -> UnixTimeMicros-createUnixTimeMicros hour minute second (Micros micros) =- check "createUnixTimeMicros" $ UnixTimeMicros base- where Second seconds = midnightToTime hour minute second- base = seconds * 1000000 + fromIntegral micros---- | Create a Unix time with nanosecond granularity.------ > >>> createUnixTimeNanos 23 19 54 465837593--- > 23:19:54.465837593----createUnixTimeNanos :: Hour -> Minute -> Second -> Nanos -> UnixTimeNanos-createUnixTimeNanos hour minute second (Nanos nanos) =- check "createUnixTimeNanos" $ UnixTimeNanos base- where Second seconds = midnightToTime hour minute second- base = seconds * 1000000000 + fromIntegral nanos---- | Create a Unix time with picosecond granularity.------ > >>> createUnixTimePicos 17 25 36 759230473534--- > 17:25:36.759230473534----createUnixTimePicos :: Hour -> Minute -> Second -> Picos -> UnixTimePicos-createUnixTimePicos hour minute second (Picos picos) =- check "createUnixTimePicos" $ UnixTimePicos base- where Second seconds = midnightToTime hour minute second- base = seconds * 1000000000000 + fromIntegral picos---- | Create a Unix date and time.------ > >>> createUnixDateTime 2012 April 27 7 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 2 8 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 1 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 2 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 time into a human-readable format.-decompUnixTime :: UnixTime -> TimeStruct-decompUnixTime (UnixTime base) =- TimeStruct hour mn sec- where (hour, mod1) = fromIntegral *** fromIntegral $ divMod base 3600- (mn , sec ) = fmap realToFrac $ divMod mod1 0060---- | Decompose a Unix time with millisecond granularity into a human-readable format.-decompUnixTimeMillis :: UnixTimeMillis -> TimeStruct-decompUnixTimeMillis (UnixTimeMillis base) =- TimeStruct hour mn $ sec + mill / 1000- where (hour, mod1) = fromIntegral *** fromIntegral $ divMod base 3600000- (mn , mod2) = divMod mod1 0060000- (sec , mill) = realToFrac *** realToFrac $ divMod mod2 0001000---- | Decompose a Unix time with microsecond granularity into a human-readable format.-decompUnixTimeMicros :: UnixTimeMicros -> TimeStruct-decompUnixTimeMicros (UnixTimeMicros base) =- TimeStruct hour mn $ sec + micr / 1000000- where (hour, mod1) = Hour *** Minute $ divMod base 3600000000- (mn , mod2) = divMod mod1 0060000000- (sec , micr) = realToFrac *** realToFrac $ divMod mod2 0001000000---- | Decompose a Unix time with nanosecond granularity into a human-readable format.-decompUnixTimeNanos :: UnixTimeNanos -> TimeStruct-decompUnixTimeNanos (UnixTimeNanos base) =- TimeStruct hour mn $ sec + nano / 1000000000- where (hour, mod1) = Hour *** Minute $ divMod base 3600000000000- (mn , mod2) = divMod mod1 0060000000000- (sec , nano) = realToFrac *** realToFrac $ divMod mod2 0001000000000---- | Decompose a Unix time with picosecond granularity into a human-readable format.-decompUnixTimePicos :: UnixTimePicos -> TimeStruct-decompUnixTimePicos (UnixTimePicos base) =- TimeStruct hour mn $ sec + pico / 1000000000000- where (hour, mod1) = Hour *** Minute $ divMod base 3600000000000000- (mn , mod2) = divMod mod1 0060000000000000- (sec , pico) = realToFrac *** realToFrac $ divMod mod2 0001000000000000---- | 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) = 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 / 1000- where DateStruct{..} = decompUnixDate $ UnixDate date- (date, mod1) = fromIntegral *** Hour $ divMod base 86400000- (hour, mod2) = fmap fromIntegral $ divMod mod1 03600000- (mn , mod3) = divMod mod2 00060000- (sec , mill) = 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) = fromIntegral *** Hour $ divMod base 86400000000- (hour, mod2) = fmap fromIntegral $ divMod mod1 03600000000- (mn , mod3) = divMod mod2 00060000000- (sec , micr) = 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 / 1000000000) . 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 . _udt_sec_base--instance Convertible UnixDateTime UnixTime where- safeConvert = Right . UnixTime . fromIntegral . flip mod 00000086400 . _udt_sec_base--instance Convertible UnixDateTimeMillis UnixDate where- safeConvert = Right . UnixDate . fromIntegral . flip div 00086400000 . _udt_mil_base--instance Convertible UnixDateTimeMillis UnixTime where- safeConvert = Right . UnixTime . fromIntegral . flip mod 00086400000 . _udt_mil_base--instance Convertible UnixDateTimeMicros UnixDate where- safeConvert = Right . UnixDate . fromIntegral . flip div 86400000000 . _udt_mic_base--instance Convertible UnixDateTimeMicros UnixTime where- safeConvert = Right . UnixTime . fromIntegral . flip mod 86400000000 . _udt_mic_base--instance Convertible UnixDateTimeNanos UnixDate where- safeConvert = Right . UnixDate . fromIntegral . flip div 86400000000 . _udt_nan_base--instance Convertible UnixDateTimeNanos UnixTime where- safeConvert = Right . UnixTime . fromIntegral . flip mod 86400000000 . _udt_nan_base--instance Convertible UnixDateTimePicos UnixDate where- safeConvert = Right . UnixDate . fromIntegral . flip div 86400000000 . _udt_pic_base--instance Convertible UnixDateTimePicos UnixTime where- safeConvert = Right . UnixTime . fromIntegral . flip mod 86400000000 . _udt_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 Time UnixTime where- toTimeStruct = decompUnixTime- fromTimeStruct TimeStruct{..} =- createUnixTime _t_hour _t_min sec- where sec = round _t_sec--instance Time UnixTimeMillis where- toTimeStruct = decompUnixTimeMillis- fromTimeStruct TimeStruct{..} =- createUnixTimeMillis _t_hour _t_min sec mil- where (sec, mil) = properFracMillis _t_sec--instance Time UnixTimeMicros where- toTimeStruct = decompUnixTimeMicros- fromTimeStruct TimeStruct{..} =- createUnixTimeMicros _t_hour _t_min sec mic- where (sec, mic) = properFracMicros _t_sec--instance Time UnixTimeNanos where- toTimeStruct = decompUnixTimeNanos- fromTimeStruct TimeStruct{..} =- createUnixTimeNanos _t_hour _t_min sec nan- where (sec, nan) = properFracNanos _t_sec--instance Time UnixTimePicos where- toTimeStruct = decompUnixTimePicos- fromTimeStruct TimeStruct{..} =- createUnixTimePicos _t_hour _t_min sec pic- where (sec, pic) = properFracPicos _t_sec--instance Time UnixDateTime where- toTimeStruct = decompUnixTime . convert- fromTimeStruct TimeStruct{..} =- createUnixDateTime 1970 January 1 _t_hour _t_min sec- where sec = round _t_sec--instance Time UnixDateTimeMillis where- toTimeStruct = decompUnixTime . convert- fromTimeStruct TimeStruct{..} =- createUnixDateTimeMillis 1970 January 1 _t_hour _t_min sec mil- where (sec, mil) = properFracMillis _t_sec--instance Time UnixDateTimeMicros where- toTimeStruct = decompUnixTime . convert- fromTimeStruct TimeStruct{..} =- createUnixDateTimeMicros 1970 January 1 _t_hour _t_min sec mic- where (sec, mic) = properFracMicros _t_sec--instance Time UnixDateTimeNanos where- toTimeStruct = decompUnixTime . convert- fromTimeStruct TimeStruct{..} =- createUnixDateTimeNanos 1970 January 1 _t_hour _t_min sec nan- where (sec, nan) = properFracNanos _t_sec--instance Time UnixDateTimePicos where- toTimeStruct = decompUnixTime . convert- fromTimeStruct TimeStruct{..} =- createUnixDateTimePicos 1970 January 1 _t_hour _t_min sec pic- where (sec, pic) = properFracPicos _t_sec--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 UnixTime where- show time = printf "%02d:%02d:%02d" _t_hour _t_min sec- where TimeStruct{..} = toTimeStruct time- sec = round _t_sec :: Second--instance Show UnixTimeMillis where- show time = printf "%02d:%02d:%02d.%03d" _t_hour _t_min sec mil- where TimeStruct{..} = toTimeStruct time- (sec, mil) = properFracMillis _t_sec--instance Show UnixTimeMicros where- show time = printf "%02d:%02d:%02d.%06d" _t_hour _t_min sec mic- where TimeStruct{..} = toTimeStruct time- (sec, mic) = properFracMicros _t_sec--instance Show UnixTimeNanos where- show time = printf "%02d:%02d:%02d.%09d" _t_hour _t_min sec nan- where TimeStruct{..} = toTimeStruct time- (sec, nan) = properFracNanos _t_sec--instance Show UnixTimePicos where- show time = printf "%02d:%02d:%02d.%012d" _t_hour _t_min sec pic- where TimeStruct{..} = toTimeStruct time- (sec, pic) = properFracPicos _t_sec--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 mil- where DateTimeStruct{..} = toDateTimeStruct time- mon = fromEnum _dt_mon + 1- (sec, mil) = 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 mic- where DateTimeStruct{..} = toDateTimeStruct time- mon = fromEnum _dt_mon + 1- (sec, mic) = 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 nan- where DateTimeStruct{..} = toDateTimeStruct time- mon = fromEnum _dt_mon + 1- (sec, nan) = 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 pic- where DateTimeStruct{..} = toDateTimeStruct time- mon = fromEnum _dt_mon + 1- (sec, pic) = 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 time from the system clock.------ > >>> getCurrentUnixTime--- > 05:45:06----getCurrentUnixTime :: IO UnixTime-getCurrentUnixTime = getCurrentUnixDateTime >>= return . convert---- | Get the current Unix time with millisecond granularity from the system clock.------ > >>> getCurrentUnixTimeMillis--- > 06:30:08.840----getCurrentUnixTimeMillis :: IO UnixTimeMillis-getCurrentUnixTimeMillis =- 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 $! UnixTimeMillis . fromIntegral $ (base `mod` 86400) * 1000 + micr `div` 1000- getResult _ _ = error "getCurrentUnixTimeMillis: unknown"---- | Get the current Unix time with microsecond granularity from the system clock.------ > >>> getCurrentUnixTimeMicros--- > 06:40:39.102910----getCurrentUnixTimeMicros :: IO UnixTimeMicros-getCurrentUnixTimeMicros =- 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 $! UnixTimeMicros $ (base `mod` 86400) * 1000000 + micr- getResult _ _ = error "getCurrentUnixTimeMicros: unknown"---- | Get the current Unix time with nanosecond granularity from the system clock.------ > >>> getCurrentUnixTimeNanos--- > 06:40:45.903610000------ Note that this functions calls @gettimeofday@ behind the scenes. Therefore,--- the resultant timestamp will have nanosecond granularity, but only microsecond--- resolution.-getCurrentUnixTimeNanos :: IO UnixTimeNanos-getCurrentUnixTimeNanos =- 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 $! UnixTimeNanos $ (base `mod` 86400) * 1000000000 + micr * 1000- getResult _ _ = error "getCurrentUnixTimeNanos: unknown"---- | Get the current Unix time with picosecond granularity from the system clock.------ > >>> getCurrentUnixTimePicos--- > 06:47:15.379247000000------ Note that this functions calls @gettimeofday@ behind the scenes. Therefore,--- the resultant timestamp will have picosecond granularity, but only microsecond--- resolution.-getCurrentUnixTimePicos :: IO UnixTimePicos-getCurrentUnixTimePicos =- 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 $! UnixTimePicos $ (base `mod` 86400) * 1000000000000 + micr * 1000000- getResult _ _ = error "getCurrentUnixTimePicos: unknown"---- | 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 nanosecond 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.-fromNanos :: UnixDateTimeNanos -> Integer-fromNanos (UnixDateTimeNanos base nano) = toInteger base * 0001000 + toInteger nano---- | Convert a Unix date and time with picosecond granularity into an integer.-fromPicos :: UnixDateTimePicos -> Integer-fromPicos (UnixDateTimePicos base pico) = toInteger base * 1000000 + toInteger pico---- | Convert an integer into a Unix date and time with nanosecond granularity.-toNanos :: Integer -> UnixDateTimeNanos-toNanos = uncurry UnixDateTimeNanos . (fromInteger *** fromInteger) . flip divMod 0001000---- | Convert an integer into a Unix date and time with picosecond granularity.-toPicos :: Integer -> UnixDateTimePicos-toPicos = uncurry UnixDateTimePicos . (fromInteger *** fromInteger) . flip divMod 1000000--instance Duration UnixDate Day where- duration (UnixDate old) (UnixDate new) = Day (new - old)--instance Duration UnixTime Hour where- duration (UnixTime old) (UnixTime new) = fromIntegral (new - old) `div` 3600--instance Duration UnixTime Minute where- duration (UnixTime old) (UnixTime new) = fromIntegral (new - old) `div` 60--instance Duration UnixTime Second where- duration (UnixTime old) (UnixTime new) = fromIntegral (new - old)--instance Duration UnixTimeMillis Hour where- duration (UnixTimeMillis old) (UnixTimeMillis new) = fromIntegral (new - old) `div` 3600000--instance Duration UnixTimeMillis Minute where- duration (UnixTimeMillis old) (UnixTimeMillis new) = fromIntegral (new - old) `div` 60000--instance Duration UnixTimeMillis Second where- duration (UnixTimeMillis old) (UnixTimeMillis new) = fromIntegral (new - old) `div` 1000--instance Duration UnixTimeMillis Millis where- duration (UnixTimeMillis old) (UnixTimeMillis new) = fromIntegral (new - old)--instance Duration UnixTimeMicros Hour where- duration (UnixTimeMicros old) (UnixTimeMicros new) = Hour (new - old) `div` 3600000000--instance Duration UnixTimeMicros Minute where- duration (UnixTimeMicros old) (UnixTimeMicros new) = Minute (new - old) `div` 60000000--instance Duration UnixTimeMicros Second where- duration (UnixTimeMicros old) (UnixTimeMicros new) = Second (new - old) `div` 1000000--instance Duration UnixTimeMicros Millis where- duration (UnixTimeMicros old) (UnixTimeMicros new) = Millis (new - old) `div` 1000--instance Duration UnixTimeMicros Micros where- duration (UnixTimeMicros old) (UnixTimeMicros new) = Micros (new - old)--instance Duration UnixTimeNanos Hour where- duration (UnixTimeNanos old) (UnixTimeNanos new) = Hour (new - old) `div` 3600000000000--instance Duration UnixTimeNanos Minute where- duration (UnixTimeNanos old) (UnixTimeNanos new) = Minute (new - old) `div` 60000000000--instance Duration UnixTimeNanos Second where- duration (UnixTimeNanos old) (UnixTimeNanos new) = Second (new - old) `div` 1000000000--instance Duration UnixTimeNanos Millis where- duration (UnixTimeNanos old) (UnixTimeNanos new) = Millis (new - old) `div` 1000000--instance Duration UnixTimeNanos Micros where- duration (UnixTimeNanos old) (UnixTimeNanos new) = Micros (new - old) `div` 1000--instance Duration UnixTimeNanos Nanos where- duration (UnixTimeNanos old) (UnixTimeNanos new) = Nanos (new - old)--instance Duration UnixTimePicos Hour where- duration (UnixTimePicos old) (UnixTimePicos new) = Hour (new - old) `div` 3600000000000000--instance Duration UnixTimePicos Minute where- duration (UnixTimePicos old) (UnixTimePicos new) = Minute (new - old) `div` 60000000000000--instance Duration UnixTimePicos Second where- duration (UnixTimePicos old) (UnixTimePicos new) = Second (new - old) `div` 1000000000000--instance Duration UnixTimePicos Millis where- duration (UnixTimePicos old) (UnixTimePicos new) = Millis (new - old) `div` 1000000000--instance Duration UnixTimePicos Micros where- duration (UnixTimePicos old) (UnixTimePicos new) = Micros (new - old) `div` 1000000--instance Duration UnixTimePicos Nanos where- duration (UnixTimePicos old) (UnixTimePicos new) = Nanos (new - old) `div` 1000--instance Duration UnixTimePicos Picos where- duration (UnixTimePicos old) (UnixTimePicos new) = Picos (new - old)--instance Duration UnixDateTime Day where- duration (UnixDateTime old) (UnixDateTime new) = fromIntegral $ (new - old) `div` 86400--instance Duration UnixDateTime Hour where- duration (UnixDateTime old) (UnixDateTime new) = Hour (new - old) `div` 3600--instance Duration UnixDateTime Minute where- duration (UnixDateTime old) (UnixDateTime new) = Minute (new - old) `div` 60--instance Duration UnixDateTime Second where- duration (UnixDateTime old) (UnixDateTime new) = Second (new - old)--instance Duration UnixDateTimeMillis Day where- duration (UnixDateTimeMillis old) (UnixDateTimeMillis new) = fromIntegral $ (new - old) `div` 86400000--instance Duration UnixDateTimeMillis Hour where- duration (UnixDateTimeMillis old) (UnixDateTimeMillis new) = Hour (new - old) `div` 3600000--instance Duration UnixDateTimeMillis Minute where- duration (UnixDateTimeMillis old) (UnixDateTimeMillis new) = Minute (new - old) `div` 60000--instance Duration UnixDateTimeMillis Second where- duration (UnixDateTimeMillis old) (UnixDateTimeMillis new) = Second (new - old) `div` 1000--instance Duration UnixDateTimeMillis Millis where- duration (UnixDateTimeMillis old) (UnixDateTimeMillis new) = Millis (new - old)--instance Duration UnixDateTimeMicros Day where- duration (UnixDateTimeMicros old) (UnixDateTimeMicros new) = fromIntegral $ (new - old) `div` 86400000000--instance Duration UnixDateTimeMicros Hour where- duration (UnixDateTimeMicros old) (UnixDateTimeMicros new) = Hour (new - old) `div` 3600000000--instance Duration UnixDateTimeMicros Minute where- duration (UnixDateTimeMicros old) (UnixDateTimeMicros new) = Minute (new - old) `div` 60000000--instance Duration UnixDateTimeMicros Second where- duration (UnixDateTimeMicros old) (UnixDateTimeMicros new) = Second (new - old) `div` 1000000--instance Duration UnixDateTimeMicros Millis where- duration (UnixDateTimeMicros old) (UnixDateTimeMicros new) = Millis (new - old) `div` 1000--instance Duration UnixDateTimeMicros Micros where- duration (UnixDateTimeMicros old) (UnixDateTimeMicros new) = Micros (new - old)--instance Duration UnixDateTimeNanos Day where- duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = fromIntegral $ (new - old) `div` 86400000000--instance Duration UnixDateTimeNanos Hour where- duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = Hour (new - old) `div` 3600000000--instance Duration UnixDateTimeNanos Minute where- duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = Minute (new - old) `div` 60000000--instance Duration UnixDateTimeNanos Second where- duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = Second (new - old) `div` 1000000--instance Duration UnixDateTimeNanos Millis where- duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = Millis (new - old) `div` 1000--instance Duration UnixDateTimeNanos Micros where- duration (UnixDateTimeNanos old _) (UnixDateTimeNanos new _) = Micros (new - old)--instance Duration UnixDateTimeNanos Nanos where- duration old new =- if res < toInteger (maxBound::Int64) then fromInteger res- else error "duration{UnixDateTimeNanos,Nanos}: integer overflow"- where res = (fromNanos new - fromNanos old)--instance Duration UnixDateTimePicos Day where- duration (UnixDateTimePicos old _) (UnixDateTimePicos new _) = fromIntegral $ (new - old) `div` 86400000000--instance Duration UnixDateTimePicos Hour where- duration (UnixDateTimePicos old _) (UnixDateTimePicos new _) = Hour (new - old) `div` 3600000000--instance Duration UnixDateTimePicos Minute where- duration (UnixDateTimePicos old _) (UnixDateTimePicos new _) = Minute (new - old) `div` 60000000--instance Duration UnixDateTimePicos Second where- duration (UnixDateTimePicos old _) (UnixDateTimePicos new _) = Second (new - old) `div` 1000000--instance Duration UnixDateTimePicos Millis where- duration (UnixDateTimePicos old _) (UnixDateTimePicos new _) = Millis (new - old) `div` 1000--instance Duration UnixDateTimePicos Micros where- duration (UnixDateTimePicos old _) (UnixDateTimePicos new _) = Micros (new - old)--instance Duration UnixDateTimePicos Nanos where- duration old new =- if res < toInteger (maxBound::Int64) then fromInteger res- else error "duration{UnixDateTimePicos,Nanos}: integer overflow"- where res = (fromPicos new - fromPicos old) `div` 1000--instance Duration UnixDateTimePicos Picos where- duration old new =- if res < toInteger (maxBound::Int64) then fromInteger res- else error "duration{UnixDateTimePicos,Picos}: integer overflow"- where res = (fromPicos new - fromPicos old)--instance Random UnixDate where- random = first toEnum . randomR (0,2932896)- randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b)--instance Random UnixTime where- random = first toEnum . randomR (0,86399)- randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b)--instance Random UnixTimeMillis where- random = first toEnum . randomR (0,86399999)- randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b)--instance Random UnixTimeMicros where- random = first toEnum . randomR (0,86399999999)- randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b)--instance Random UnixTimeNanos where- random = first toEnum . randomR (0,86399999999999)- randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b)--instance Random UnixTimePicos where- random = first toEnum . randomR (0,86399999999999999)- randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b)--instance Random UnixDateTime where- random = first toEnum . randomR (0,253402300799)- randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b)--instance Random UnixDateTimeMillis where- random = first toEnum . randomR (0,253402300799999)- randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b)--instance Random UnixDateTimeMicros where- random = first toEnum . randomR (0,253402300799999999)- randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b)--instance Random UnixDateTimeNanos where- random = first toNanos . randomR (0,253402300799999999999)- randomR (a,b) = first toNanos . randomR (fromNanos a, fromNanos b)--instance Random UnixDateTimePicos where- random = first toPicos . randomR (0,253402300799999999999999)- randomR (a,b) = first toPicos . randomR (fromPicos a, fromPicos 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 time as a pretty string.------ > >>> getCurrentUnixTime >>= putStrLn . prettyUnixTime --- > 9:12 AM----prettyUnixTime :: (Unix t, Time t) => t -> String-prettyUnixTime time =- printf "%d:%02d %s" hour _t_min ampm - where TimeStruct{..} = toTimeStruct time- ampm = showPeriod _t_hour- hour | _t_hour == 00 = 12- | _t_hour <= 12 = _t_hour- | otherwise = _t_hour - 12---- | 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))
− src/Data/Time/Exts/Zone.hs
@@ -1,502 +0,0 @@------------------------------------------------------------------- Copyright (c) 2014, Enzo Haussecker. All rights reserved. --------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# 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- City(..)- , cities-- -- ** Olson Database- , getOlsonFile- , olsonFiles-- -- ** Time Zones- , TimeZone(..)- , utc- , getUTCOffset- , utcOffsets-- -- ** Abbreviations- , TimeZoneAbbr(..)- , abbreviate- , unabbreviate- , abbreviations-- ) where--import Control.Arrow (first)-import Data.Aeson (FromJSON, ToJSON)-import Data.Convertible (convError, convert, Convertible(..))-import Data.Map.Strict (Map, (!), fromDistinctAscList)-import Data.Typeable (Typeable)-import GHC.Generics (Generic)-import System.Random (Random(..))---- | Cities from around the world.-data City =- Aden -- ^ Yemeni Republic- | Amman -- ^ Hashemite Kingdom of Jordan- | Anchorage -- ^ United States of America- | Auckland -- ^ New Zealand- | Baghdad -- ^ Republic of Iraq- | Berlin -- ^ Federal Republic of Germany- | Brussels -- ^ Kingdom of Belgium- | Bujumbura -- ^ Republic of Burundi- | Cairo -- ^ Arab Republic of Egypt- | Chicago -- ^ United States of America- | Damascus -- ^ Syrian Arab Republic- | Denver -- ^ United States of America- | Doha -- ^ State of Qatar- | Gaborone -- ^ Republic of Botswana- | Hong_Kong -- ^ People's Republic of China- | Honolulu -- ^ United States of America- | Johannesburg -- ^ Republic of South Africa- | Kabul -- ^ Islamic Republic of Afghanistan- | Karachi -- ^ Islamic Republic of Pakistan- | Kinshasa -- ^ Democratic Republic of the Congo- | Kolkata -- ^ Republic of India- | Kuwait_City -- ^ State of Kuwait- | London -- ^ United Kingdom of Great Britain and Northern Ireland- | Los_Angeles -- ^ United States of America- | Luanda -- ^ Republic of Angola- | Manama -- ^ Kingdom of Bahrain- | Minsk -- ^ Republic of Belarus- | Mogadishu -- ^ Federal Republic of Somalia- | Moscow -- ^ Russian Federation- | New_York -- ^ United States of America- | Oslo -- ^ Kingdom of Norway- | Ouagadougou -- ^ Burkina Faso- | Paris -- ^ French Republic- | Pyongyang -- ^ Democratic People's Republic of Korea- | Riyadh -- ^ Kingdom of Saudi Arabia- | Sao_Paulo -- ^ Federative Republic of Brazil- | Sarajevo -- ^ Bosnia and Herzegovina- | Seoul -- ^ Republic of Korea- | Shanghai -- ^ People's Republic of China- | Singapore -- ^ Republic of Singapore- | Sofia -- ^ Republic of Bulgaria- | Stockholm -- ^ Kingdom of Sweden- | Tehran -- ^ Islamic Republic of Iran- | Tel_Aviv -- ^ State of Israel- | Tirana -- ^ Republic of Albania- | Tokyo -- ^ Japan- | Toronto -- ^ Canada- | Universal -- ^ International Territory- | Vienna -- ^ Republic of Austria- | Zurich -- ^ Swiss Confederation- 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- | Alaska_Daylight_Time- | Alaska_Hawaii_Daylight_Time- | Alaska_Hawaii_Standard_Time- | Alaska_Standard_Time- | Arabia_Daylight_Time- | Arabia_Standard_Time- | Brasilia_Summer_Time- | Brasilia_Time- | British_Summer_Time- | Central_Africa_Time- | Central_Daylight_Time- | Central_European_Summer_Time- | Central_European_Time- | Central_Standard_Time- | China_Daylight_Time- | China_Standard_Time- | Coordinated_Universal_Time- | East_Africa_Time- | Eastern_Daylight_Time- | Eastern_European_Summer_Time- | Eastern_European_Time- | Eastern_Standard_Time- | Further_Eastern_European_Time- | Greenwich_Mean_Time- | Gulf_Standard_Time- | Hawaii_Aleutian_Standard_Time- | Hong_Kong_Summer_Time- | Hong_Kong_Time- | India_Standard_Time- | Iran_Daylight_Time- | Iran_Standard_Time- | Israel_Daylight_Time- | Israel_Standard_Time- | Japan_Standard_Time- | Karachi_Time- | Korea_Daylight_Time- | Korea_Standard_Time- | Moscow_Daylight_Time- | Moscow_Standard_Time- | Mountain_Daylight_Time- | Mountain_Standard_Time- | New_Zealand_Daylight_Time- | New_Zealand_Standard_Time- | Pacific_Daylight_Time- | Pacific_Standard_Time- | Pakistan_Standard_Time- | Pakistan_Summer_Time- | Singapore_Time- | South_Africa_Standard_Time- | West_Africa_Time- | Yukon_Standard_Time- deriving (Eq,Enum,Generic,Ord,Read,Show,Typeable)--instance Bounded TimeZone where- minBound = Afghanistan_Time- maxBound = Yukon_Standard_Time--instance FromJSON TimeZone--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 ToJSON TimeZone---- | The UTC time zone.-utc :: TimeZone -utc = Coordinated_Universal_Time---- | Get the UTC offset (in minutes) for the given time zone.-getUTCOffset :: Num a => TimeZone -> a-getUTCOffset = (!) utcOffsets---- | 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 Convertible TimeZoneAbbr TimeZone where- safeConvert abbr@TimeZoneAbbr{..} = - case abbr_str of- "AFT" -> Right Afghanistan_Time- "AHDT" -> Right Alaska_Hawaii_Daylight_Time- "AHST" -> Right Alaska_Hawaii_Standard_Time- "AKDT" -> Right Alaska_Daylight_Time- "AKST" -> Right Alaska_Standard_Time- "ADT" -> Right Arabia_Daylight_Time- "AST" -> Right Arabia_Standard_Time- "BRST" -> Right Brasilia_Summer_Time- "BRT" -> Right Brasilia_Time- "BST" -> Right British_Summer_Time- "CAT" -> Right Central_Africa_Time- "CDT" -> case abbr_city of- Chicago -> Right Central_Daylight_Time- Shanghai -> Right China_Daylight_Time- _ -> collision- "CEST" -> Right Central_European_Summer_Time- "CET" -> Right Central_European_Time- "CST" -> case abbr_city of- Chicago -> Right Central_Standard_Time- Shanghai -> Right China_Standard_Time- _ -> collision- "EAT" -> Right East_Africa_Time- "EDT" -> Right Eastern_Daylight_Time- "EEST" -> Right Eastern_European_Summer_Time- "EET" -> Right Eastern_European_Time- "EST" -> Right Eastern_Standard_Time- "FET" -> Right Further_Eastern_European_Time- "GMT" -> Right Greenwich_Mean_Time- "GST" -> Right Gulf_Standard_Time- "HST" -> Right Hawaii_Aleutian_Standard_Time- "HKST" -> Right Hong_Kong_Summer_Time- "HKT" -> Right Hong_Kong_Time- "IDT" -> Right Israel_Daylight_Time- "IRDT" -> Right Iran_Daylight_Time- "IRST" -> Right Iran_Standard_Time- "IST" -> case abbr_city of- Kolkata -> Right India_Standard_Time- Tel_Aviv -> Right Israel_Standard_Time- _ -> collision- "JST" -> Right Japan_Standard_Time- "KART" -> Right Karachi_Time- "KDT" -> Right Korea_Daylight_Time- "KST" -> Right Korea_Standard_Time- "MDT" -> Right Mountain_Daylight_Time- "MSD" -> Right Moscow_Daylight_Time- "MSK" -> Right Moscow_Standard_Time- "MST" -> Right Mountain_Standard_Time- "NZDT" -> Right New_Zealand_Daylight_Time- "NZST" -> Right New_Zealand_Standard_Time- "PDT" -> Right Pacific_Daylight_Time- "PKST" -> Right Pakistan_Summer_Time- "PKT" -> Right Pakistan_Standard_Time- "PST" -> Right Pacific_Standard_Time- "SAST" -> Right South_Africa_Standard_Time- "SGT" -> Right Singapore_Time- "UTC" -> Right Coordinated_Universal_Time- "WAT" -> Right West_Africa_Time- "YST" -> Right Yukon_Standard_Time- _ -> convError "undefined time zone abbreviation string" abbr- where collision = convError "reference location collision" abbr--instance Convertible TimeZone TimeZoneAbbr where- safeConvert = Right . (!) abbreviations--instance FromJSON TimeZoneAbbr--instance Show TimeZoneAbbr where- show TimeZoneAbbr{abbr_str} = abbr_str--instance ToJSON TimeZoneAbbr---- | Abbreviate a time zone.-abbreviate :: TimeZone -> TimeZoneAbbr-abbreviate = convert---- | Unabbreviate a time zone.-unabbreviate :: TimeZoneAbbr -> TimeZone-unabbreviate = convert---- | 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")- ]
+ stack.yaml view
@@ -0,0 +1,4 @@+resolver: lts-6.14++packages:+- '.'
time-exts.cabal view
@@ -1,66 +1,72 @@-Name: time-exts-Version: 2.1.0-License: BSD3-License-File: LICENSE-Copyright: Copyright (c) 2014, Enzo Haussecker. All rights reserved.-Author: Enzo Haussecker <enzo@ucsd.edu>-Maintainer: Enzo Haussecker <enzo@ucsd.edu>-Stability: Stable-Category: Time-Synopsis: Efficient Timestamps-Homepage: https://github.com/enzoh/time-exts-Bug-Reports: https://github.com/enzoh/time-exts/issues-Build-Type: Simple-Cabal-Version: >= 1.16.0-Description: Haskell timestamps in various bit length and granularity.+name: time-exts+version: 3.0.0+synopsis: Yet another time library+license: BSD3+author: Enzo Haussecker+maintainer: enzo@sovereign.io+copyright: 2013-2016 Enzo Haussecker+category: Time+build-type: Simple+cabal-version: >=1.10 -Library- Default-Language: Haskell2010- HS-Source-Dirs: src- Exposed-Modules: Data.Time.Exts- Data.Time.Exts.Base- Data.Time.Exts.C- Data.Time.Exts.Local- Data.Time.Exts.Parser- Data.Time.Exts.Unix- Data.Time.Exts.Zone- Build-Depends: aeson,- attoparsec,- base >= 4 && < 5,- bindings-DSL,- containers,- convertible,- data-default,- deepseq,- fclabels,- mtl,- old-locale,- QuickCheck,- random,- text,- time,- timezone-olson- Build-Tools: hsc2hs+library+ default-language:+ Haskell2010+ exposed-modules:+ Data.Time.Exts+ Data.Time.Exts.Base+ Data.Time.Exts.Format+ Data.Time.Exts.UTC+ Data.Time.Exts.Unix+ other-modules:+ Data.Time.Exts.Lens+ Data.Time.Exts.Parser+ Data.Time.Exts.Util+ Foreign.C.Time+ build-depends:+ attoparsec,+ base >=4.8 && <4.10,+ bindings-DSL,+ deepseq,+ lens-simple,+ mtl,+ old-locale,+ random,+ text,+ time,+ tz+ ghc-options:+ -Wall -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,- attoparsec,- base >= 4 && < 5,- bindings-DSL,- containers,- convertible,- data-default,- deepseq,- fclabels,- mtl,- old-locale,- QuickCheck,- random,- text,- time,- timezone-olson- Build-Tools: hsc2hs+test-suite time-exts-unit-tests+ default-language:+ Haskell2010+ type:+ exitcode-stdio-1.0+ main-is:+ Test.hs+ other-modules:+ Data.Time.Exts.Base+ Data.Time.Exts.Format+ Data.Time.Exts.Lens+ Data.Time.Exts.Parser+ Data.Time.Exts.Unix+ Data.Time.Exts.Util+ Foreign.C.Time+ build-depends:+ attoparsec,+ base,+ bindings-DSL,+ deepseq,+ HUnit,+ ieee754,+ lens-simple,+ mtl,+ old-locale,+ QuickCheck,+ random,+ text,+ time,+ tz+ ghc-options:+ -Wall