diff --git a/src/Data/Time/Exts.hs b/src/Data/Time/Exts.hs --- a/src/Data/Time/Exts.hs +++ b/src/Data/Time/Exts.hs @@ -16,6 +16,9 @@ -- ** 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 @@ -27,5 +30,6 @@ 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/Local.hs b/src/Data/Time/Exts/Local.hs --- a/src/Data/Time/Exts/Local.hs +++ b/src/Data/Time/Exts/Local.hs @@ -261,23 +261,23 @@ maxBound = LocalDate 2932896 maxzone instance Bounded LocalDateTime where - minBound = LocalDateTime 43200 0 + minBound = LocalDateTime 0 0 maxBound = LocalDateTime 253402257624 maxzone instance Bounded LocalDateTimeMillis where - minBound = LocalDateTimeMillis 43200000 0 + minBound = LocalDateTimeMillis 0 0 maxBound = LocalDateTimeMillis 253402257624999 maxzone instance Bounded LocalDateTimeMicros where - minBound = LocalDateTimeMicros 43200000000 0 + minBound = LocalDateTimeMicros 0 0 maxBound = LocalDateTimeMicros 253402257624999999 maxzone instance Bounded LocalDateTimeNanos where - minBound = LocalDateTimeNanos 43200000000 0 0 + minBound = LocalDateTimeNanos 0 0 0 maxBound = LocalDateTimeNanos 253402257624999999 999 maxzone instance Bounded LocalDateTimePicos where - minBound = LocalDateTimePicos 43200000000 0 0 + minBound = LocalDateTimePicos 0 0 0 maxBound = LocalDateTimePicos 253402257624999999 999999 maxzone instance Local LocalDate where diff --git a/src/Data/Time/Exts/Parser.hs b/src/Data/Time/Exts/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Exts/Parser.hs @@ -0,0 +1,770 @@ +-------------------------------------------------------------------------------- +-- 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 --- a/src/Data/Time/Exts/Test.hs +++ b/src/Data/Time/Exts/Test.hs @@ -9,6 +9,7 @@ module Main where +import Control.Monad import Data.Convertible import Data.Time.Calendar as Calendar import Data.Time.Clock @@ -59,19 +60,19 @@ arbitrary = choose (minBound, maxBound) instance Arbitrary LocalDateTime where - arbitrary = choose (minBound, maxBound) + arbitrary = choose (minBound `plus` Second 43200, maxBound) instance Arbitrary LocalDateTimeMillis where - arbitrary = choose (minBound, maxBound) + arbitrary = choose (minBound `plus` Second 43200, maxBound) instance Arbitrary LocalDateTimeMicros where - arbitrary = choose (minBound, maxBound) + arbitrary = choose (minBound `plus` Second 43200, maxBound) instance Arbitrary LocalDateTimeNanos where - arbitrary = choose (minBound, maxBound) + arbitrary = choose (minBound `plus` Second 43200, maxBound) instance Arbitrary LocalDateTimePicos where - arbitrary = choose (minBound, maxBound) + 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 @@ -143,7 +144,7 @@ -- | Test properties. main :: IO () -main = do +main = replicateM_ 100 $ do quickCheck (test1 :: UnixDateTime -> Bool) quickCheck (test1 :: UnixDateTimeMillis -> Bool) quickCheck (test1 :: UnixDateTimeMicros -> Bool) diff --git a/src/Data/Time/Exts/Zone.hs b/src/Data/Time/Exts/Zone.hs --- a/src/Data/Time/Exts/Zone.hs +++ b/src/Data/Time/Exts/Zone.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS -Wall #-} @@ -34,12 +35,13 @@ ) where -import Control.Arrow (first) -import Data.Aeson (FromJSON, ToJSON) -import Data.Map.Strict (Map, (!), fromDistinctAscList) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import System.Random (Random(..)) +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 = @@ -360,6 +362,73 @@ , 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 @@ -369,72 +438,11 @@ -- | Abbreviate a time zone. abbreviate :: TimeZone -> TimeZoneAbbr -abbreviate = (!) abbreviations +abbreviate = convert -- | Unabbreviate a time zone. unabbreviate :: TimeZoneAbbr -> TimeZone -unabbreviate TimeZoneAbbr{..} = - case abbr_str of - "AFT" -> Afghanistan_Time - "AHDT" -> Alaska_Hawaii_Daylight_Time - "AHST" -> Alaska_Hawaii_Standard_Time - "AKDT" -> Alaska_Daylight_Time - "AKST" -> Alaska_Standard_Time - "ADT" -> Arabia_Daylight_Time - "AST" -> Arabia_Standard_Time - "BRST" -> Brasilia_Summer_Time - "BRT" -> Brasilia_Time - "BST" -> British_Summer_Time - "CAT" -> Central_Africa_Time - "CDT" -> case abbr_city of - Chicago -> Central_Daylight_Time - Shanghai -> China_Daylight_Time - _ -> missing abbr_city - "CEST" -> Central_European_Summer_Time - "CET" -> Central_European_Time - "CST" -> case abbr_city of - Chicago -> Central_Standard_Time - Shanghai -> China_Standard_Time - _ -> missing abbr_city - "EAT" -> East_Africa_Time - "EDT" -> Eastern_Daylight_Time - "EEST" -> Eastern_European_Summer_Time - "EET" -> Eastern_European_Time - "EST" -> Eastern_Standard_Time - "FET" -> Further_Eastern_European_Time - "GMT" -> Greenwich_Mean_Time - "GST" -> Gulf_Standard_Time - "HST" -> Hawaii_Aleutian_Standard_Time - "HKST" -> Hong_Kong_Summer_Time - "HKT" -> Hong_Kong_Time - "IDT" -> Israel_Daylight_Time - "IRDT" -> Iran_Daylight_Time - "IRST" -> Iran_Standard_Time - "IST" -> case abbr_city of - Kolkata -> India_Standard_Time - Tel_Aviv -> Israel_Standard_Time - _ -> missing abbr_city - "JST" -> Japan_Standard_Time - "KART" -> Karachi_Time - "KDT" -> Korea_Daylight_Time - "KST" -> Korea_Standard_Time - "MDT" -> Mountain_Daylight_Time - "MSD" -> Moscow_Daylight_Time - "MSK" -> Moscow_Standard_Time - "MST" -> Mountain_Standard_Time - "NZDT" -> New_Zealand_Daylight_Time - "NZST" -> New_Zealand_Standard_Time - "PDT" -> Pacific_Daylight_Time - "PKST" -> Pakistan_Summer_Time - "PKT" -> Pakistan_Standard_Time - "PST" -> Pacific_Standard_Time - "SAST" -> South_Africa_Standard_Time - "SGT" -> Singapore_Time - "UTC" -> Coordinated_Universal_Time - "WAT" -> West_Africa_Time - "YST" -> Yukon_Standard_Time - _ -> error $ "safeConvert: missing time zone abbreviation `" ++ abbr_str ++ "'" - where missing city = error $ "safeConvert: missing reference location `" ++ show city ++ "'" +unabbreviate = convert -- | A map from time zones to time zone abbreviations. abbreviations :: Map TimeZone TimeZoneAbbr diff --git a/time-exts.cabal b/time-exts.cabal --- a/time-exts.cabal +++ b/time-exts.cabal @@ -1,18 +1,18 @@ Name: time-exts -Version: 2.0.0 +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: Experimental +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: Extensions to the Haskell time library, providing efficient Unix, UTC, and local timestamps. +Description: Haskell timestamps in various bit length and granularity. Library Default-Language: Haskell2010 @@ -21,17 +21,23 @@ 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 @@ -42,14 +48,19 @@ 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