diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -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 diff --git a/Data/Time/Exts.hs b/Data/Time/Exts.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Exts.hs @@ -0,0 +1,29 @@ +-- | +-- Module : Data.Time.Exts +-- Copyright : 2013-2016 Enzo Haussecker +-- License : BSD3 +-- Maintainer : Enzo Haussecker +-- 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 diff --git a/Data/Time/Exts/Base.hs b/Data/Time/Exts/Base.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Exts/Base.hs @@ -0,0 +1,398 @@ +-- | +-- Module : Data.Time.Exts.Base +-- Copyright : 2013-2016 Enzo Haussecker +-- License : BSD3 +-- Maintainer : Enzo Haussecker +-- 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 diff --git a/Data/Time/Exts/Format.hs b/Data/Time/Exts/Format.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Exts/Format.hs @@ -0,0 +1,48 @@ +-- | +-- Module : Data.Time.Exts.Format +-- Copyright : 2013-2016 Enzo Haussecker +-- License : BSD3 +-- Maintainer : Enzo Haussecker +-- 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 diff --git a/Data/Time/Exts/Lens.hs b/Data/Time/Exts/Lens.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Exts/Lens.hs @@ -0,0 +1,24 @@ +-- | +-- Module : Data.Time.Exts.Lens +-- Copyright : 2013-2016 Enzo Haussecker +-- License : BSD3 +-- Maintainer : Enzo Haussecker +-- 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 diff --git a/Data/Time/Exts/Parser.hs b/Data/Time/Exts/Parser.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Exts/Parser.hs @@ -0,0 +1,347 @@ +-- | +-- Module : Data.Time.Exts.Parser +-- Copyright : 2013-2016 Enzo Haussecker +-- License : BSD3 +-- Maintainer : Enzo Haussecker +-- 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 diff --git a/Data/Time/Exts/UTC.hs b/Data/Time/Exts/UTC.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Exts/UTC.hs @@ -0,0 +1,442 @@ +-- | +-- Module : Data.Time.Exts.UTC +-- Copyright : 2013-2016 Enzo Haussecker +-- License : BSD3 +-- Maintainer : Enzo Haussecker +-- 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) diff --git a/Data/Time/Exts/Unix.hs b/Data/Time/Exts/Unix.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Exts/Unix.hs @@ -0,0 +1,642 @@ +-- | +-- Module : Data.Time.Exts.Unix +-- Copyright : 2013-2016 Enzo Haussecker +-- License : BSD3 +-- Maintainer : Enzo Haussecker +-- 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 diff --git a/Data/Time/Exts/Util.hs b/Data/Time/Exts/Util.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Exts/Util.hs @@ -0,0 +1,116 @@ +-- | +-- Module : Data.Time.Exts.Util +-- Copyright : 2013-2016 Enzo Haussecker +-- License : BSD3 +-- Maintainer : Enzo Haussecker +-- 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) diff --git a/Foreign/C/Time.hsc b/Foreign/C/Time.hsc new file mode 100644 --- /dev/null +++ b/Foreign/C/Time.hsc @@ -0,0 +1,76 @@ +-- | +-- Module : Foreign.C.Time +-- Copyright : 2013-2016 Enzo Haussecker +-- License : BSD3 +-- Maintainer : Enzo Haussecker +-- 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 +#include +#include + +#starttype struct tm +#field tm_sec, CInt +#field tm_min, CInt +#field tm_hour, CInt +#field tm_mday, CInt +#field tm_mon, CInt +#field tm_year, CInt +#field tm_wday, CInt +#field tm_yday, CInt +#field tm_isdst, CInt +#field tm_gmtoff, CLong +#field tm_zone, CString +#stoptype + +#starttype struct timeval +#field tv_sec, CLong +#field tv_usec, CLong +#stoptype + +#ccall timegm, Ptr -> IO CTime +#ccall gmtime_r, Ptr CTime -> Ptr -> IO (Ptr ) +#ccall gettimeofday, Ptr -> Ptr () -> IO CInt + +instance 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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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: diff --git a/README.org b/README.org new file mode 100644 --- /dev/null +++ b/README.org @@ -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]] diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -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 diff --git a/src/Data/Time/Exts.hs b/src/Data/Time/Exts.hs deleted file mode 100644 --- a/src/Data/Time/Exts.hs +++ /dev/null @@ -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 diff --git a/src/Data/Time/Exts/Base.hs b/src/Data/Time/Exts/Base.hs deleted file mode 100644 --- a/src/Data/Time/Exts/Base.hs +++ /dev/null @@ -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" diff --git a/src/Data/Time/Exts/C.hsc b/src/Data/Time/Exts/C.hsc deleted file mode 100644 --- a/src/Data/Time/Exts/C.hsc +++ /dev/null @@ -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 -#include -#include - -#starttype struct tm -#field tm_sec , CInt -#field tm_min , CInt -#field tm_hour , CInt -#field tm_mday , CInt -#field tm_mon , CInt -#field tm_year , CInt -#field tm_wday , CInt -#field tm_yday , CInt -#field tm_isdst , CInt -#field tm_gmtoff , CLong -#field tm_zone , CString -#stoptype - -#starttype struct timeval -#field tv_sec , CLong -#field tv_usec , CLong -#stoptype - -#ccall timegm , Ptr -> IO CTime -#ccall gmtime_r , Ptr CTime -> Ptr -> IO (Ptr ) -#ccall gettimeofday , Ptr -> Ptr () -> IO CInt - -instance Convertible CTime C'tm where - safeConvert = Right . unsafeLocalState . flip with f - where f x = alloca $ \ ptr -> c'gmtime_r x ptr >>= peek - -instance Convertible C'tm CTime where - safeConvert = Right . unsafeLocalState . flip with c'timegm - --- | 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 diff --git a/src/Data/Time/Exts/Local.hs b/src/Data/Time/Exts/Local.hs deleted file mode 100644 --- a/src/Data/Time/Exts/Local.hs +++ /dev/null @@ -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 diff --git a/src/Data/Time/Exts/Parser.hs b/src/Data/Time/Exts/Parser.hs deleted file mode 100644 --- a/src/Data/Time/Exts/Parser.hs +++ /dev/null @@ -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] diff --git a/src/Data/Time/Exts/Test.hs b/src/Data/Time/Exts/Test.hs deleted file mode 100644 --- a/src/Data/Time/Exts/Test.hs +++ /dev/null @@ -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) diff --git a/src/Data/Time/Exts/Unix.hs b/src/Data/Time/Exts/Unix.hs deleted file mode 100644 --- a/src/Data/Time/Exts/Unix.hs +++ /dev/null @@ -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)) diff --git a/src/Data/Time/Exts/Zone.hs b/src/Data/Time/Exts/Zone.hs deleted file mode 100644 --- a/src/Data/Time/Exts/Zone.hs +++ /dev/null @@ -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") - ] diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,4 @@ +resolver: lts-6.14 + +packages: +- '.' diff --git a/time-exts.cabal b/time-exts.cabal --- a/time-exts.cabal +++ b/time-exts.cabal @@ -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 -Maintainer: Enzo Haussecker -Stability: Stable -Category: Time -Synopsis: Efficient Timestamps -Homepage: https://github.com/enzoh/time-exts -Bug-Reports: https://github.com/enzoh/time-exts/issues -Build-Type: Simple -Cabal-Version: >= 1.16.0 -Description: 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