thyme 0.1.2.0 → 0.2.0.0
raw patch · 13 files changed
+621/−279 lines, 13 filesdep +transformersdep −mtldep ~bytestring
Dependencies added: transformers
Dependencies removed: mtl
Dependency ranges changed: bytestring
Files
- src/Data/Micro.hs +7/−7
- src/Data/Thyme/Calendar.hs +4/−4
- src/Data/Thyme/Calendar/Internal.hs +142/−24
- src/Data/Thyme/Calendar/MonthDay.hs +1/−1
- src/Data/Thyme/Calendar/OrdinalDate.hs +4/−35
- src/Data/Thyme/Calendar/WeekDate.hs +8/−18
- src/Data/Thyme/Clock.hs +1/−2
- src/Data/Thyme/Format.hs +308/−120
- src/Data/Thyme/Format/Internal.hs +44/−20
- src/Data/Thyme/LocalTime.hs +0/−21
- src/Data/Thyme/LocalTime/Internal.hs +33/−4
- tests/sanity.hs +47/−12
- thyme.cabal +22/−11
src/Data/Micro.hs view
@@ -15,10 +15,10 @@ import Data.Int import Data.Ix import Data.Ratio-import Data.VectorSpace #if !SHOW_INTERNAL-import Text.Printf+import Data.Thyme.Format.Internal #endif+import Data.VectorSpace newtype Micro = Micro Int64 deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable)@@ -27,10 +27,10 @@ deriving instance Show Micro #else instance Show Micro where- show (Micro a) = case compare a 0 of- LT -> printf "-%d.%06u" `uncurry` quotRem (negate a) 1000000- EQ -> "0"- GT -> printf "%d.%06u" `uncurry` quotRem a 1000000+ showsPrec _ (Micro a) = sign . shows si . frac where+ sign = if a < 0 then (:) '-' else id+ (si, su) = quotRem (abs a) 1000000+ frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su #endif {-# INLINE toMicro #-}@@ -48,7 +48,7 @@ {-# INLINE fromInteger #-} Micro a + Micro b = Micro (a + b) Micro a - Micro b = Micro (a - b)- Micro a * Micro b = Micro ((quot a 1000) * (quot b 1000))+ Micro a * Micro b = Micro (quot a 1000 * quot b 1000) negate (Micro a) = Micro (negate a) abs (Micro a) = Micro (abs a) signum (Micro a) = Micro (signum a * 1000000)
src/Data/Thyme/Calendar.hs view
@@ -29,7 +29,7 @@ {-# INLINEABLE fromOrdinal #-} fromOrdinal :: OrdinalDate -> YearMonthDay- fromOrdinal (OrdinalDate y yd) = (YearMonthDay y m d) where+ fromOrdinal (OrdinalDate y yd) = YearMonthDay y m d where MonthDay m d = view (monthDay (isLeapYear y)) yd {-# INLINEABLE toOrdinal #-}@@ -41,9 +41,9 @@ gregorian :: Simple Iso Day YearMonthDay gregorian = ordinalDate . yearMonthDay -{-# INLINEABLE fromGregorianValid #-}-fromGregorianValid :: YearMonthDay -> Maybe Day-fromGregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y+{-# INLINEABLE gregorianValid #-}+gregorianValid :: YearMonthDay -> Maybe Day+gregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y <$> monthDayToDayOfYearValid (isLeapYear y) (MonthDay m d) {-# INLINEABLE showGregorian #-}
src/Data/Thyme/Calendar/Internal.hs view
@@ -2,17 +2,21 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} -- #hide module Data.Thyme.Calendar.Internal where import Prelude+import Control.Applicative import Control.DeepSeq import Control.Lens+import Control.Monad import Data.AffineSpace import Data.Data import Data.Int import Data.Ix+import Data.Thyme.Format.Internal -- | The Modified Julian Day is a standard count of days, with zero being -- the day 1858-11-17.@@ -89,6 +93,10 @@ type WeekOfYear = Int type DayOfWeek = Int++-- | Weeks numbered 01 to 53, where week 01 is the first week that has at+-- least 4 days in the new year. Days before week 01 are considered to+-- belong to the previous year. data WeekDate = WeekDate { wdYear :: {-# UNPACK #-}!Year , wdWeek :: {-# UNPACK #-}!WeekOfYear@@ -97,41 +105,151 @@ instance NFData WeekDate --- | Accepts 0-based 'DayOfWeek' and 'WeekOfYear' when 'review'ing. {-# INLINE weekDate #-} weekDate :: Simple Iso Day WeekDate weekDate = iso toWeek fromWeek where {-# INLINEABLE toWeek #-} toWeek :: Day -> WeekDate- toWeek day@(ModifiedJulianDay mjd) = WeekDate- y1 (fromIntegral $ w1 + 1) (fromIntegral $ mod d 7 + 1) where- -- pilfered and refactored; no idea what foo and bar mean- OrdinalDate y0 yd = view ordinalDate day- d = mjd + 2- foo :: Year -> {-WeekOfYear-1-}Int64- foo y = bar $ review ordinalDate (OrdinalDate y 6)- bar :: Day -> {-WeekOfYear-1-}Int64- bar (ModifiedJulianDay k) = div d 7 - div k 7- w0 = bar $ ModifiedJulianDay (d - fromIntegral yd + 4)- (y1, w1) = case w0 of- -1 -> (y0 - 1, foo (y0 - 1))- 52 | foo (y0 + 1) == 0 -> (y0 + 1, 0)- _ -> (y0, w0)+ toWeek = join (toWeekOrdinal . view ordinalDate) {-# INLINEABLE fromWeek #-} fromWeek :: WeekDate -> Day- fromWeek wd@(WeekDate y _ _) = fromWeekMax wMax wd where- WeekDate _ wMax _ = toWeek $ review ordinalDate (OrdinalDate y 365)+ fromWeek wd@(WeekDate y _ _) = fromWeekLast (lastWeekOfYear y) wd -{-# INLINE fromWeekMax #-}-fromWeekMax :: WeekOfYear -> WeekDate -> Day-fromWeekMax wMax (WeekDate y w d) = ModifiedJulianDay mjd where+{-# INLINE toWeekOrdinal #-}+toWeekOrdinal :: OrdinalDate -> Day -> WeekDate+toWeekOrdinal (OrdinalDate y0 yd) (ModifiedJulianDay mjd) = WeekDate y1+ (fromIntegral $ w1 + 1) (fromIntegral $ d7mod + 1) where+ -- pilfered and refactored; no idea what foo and bar mean+ d = mjd + 2+ (d7div, d7mod) = divMod d 7+ foo :: Year -> {-WeekOfYear-1-}Int64+ foo y = bar $ review ordinalDate (OrdinalDate y 6)+ bar :: Day -> {-WeekOfYear-1-}Int64+ bar (ModifiedJulianDay k) = d7div - div k 7+ w0 = bar $ ModifiedJulianDay (d - fromIntegral yd + 4)+ (y1, w1) = case w0 of+ -1 -> (y0 - 1, foo (y0 - 1))+ 52 | foo (y0 + 1) == 0 -> (y0 + 1, 0)+ _ -> (y0, w0)++{-# INLINE lastWeekOfYear #-}+lastWeekOfYear :: Year -> WeekOfYear+lastWeekOfYear y = if wdWeek wd == 53 then 53 else 52 where+ wd = view (from ordinalDate . weekDate) (OrdinalDate y 365)++{-# INLINE fromWeekLast #-}+fromWeekLast :: WeekOfYear -> WeekDate -> Day+fromWeekLast wMax (WeekDate y w d) = ModifiedJulianDay mjd where -- pilfered and refactored ModifiedJulianDay k = review ordinalDate (OrdinalDate y 6)- -- FIXME: Is it okay to clip d to 0 in the case of Sunday-starting- -- weeks, and clip w to 0 for OrdinalDate.{sun,mon}dayStartWeek?- mjd = k - mod k 7 - 10 + clip 0 7 (fromIntegral d)- + fromIntegral (clip 0 wMax w) * 7+ mjd = k - mod k 7 - 10 + clip 1 7 (fromIntegral d)+ + fromIntegral (clip 1 wMax w) * 7 clip a b = max a . min b++{-# INLINEABLE weekDateValid #-}+weekDateValid :: WeekDate -> Maybe Day+weekDateValid wd@(WeekDate (lastWeekOfYear -> wMax) w d) =+ fromWeekLast wMax wd <$ guard (1 <= d && d <= 7 && 1 <= w && w <= wMax)++{-# INLINEABLE showWeekDate #-}+showWeekDate :: Day -> String+showWeekDate (view weekDate -> WeekDate y w d) =+ shows04 y . (++) "-W" . shows02 w . (:) '-' . shows d $ ""++------------------------------------------------------------------------+-- * Non-standard week dates++-- | Weeks numbered from 0 to 53, starting with the first Sunday of the year+-- as the first day of week 1. The last week of a given year and week 0 of+-- the next both refer to the same week.+data SundayWeek = SundayWeek+ { swYear :: {-# UNPACK #-}!Year+ , swWeek :: {-# UNPACK #-}!WeekOfYear+ , swDay :: {-# UNPACK #-}!DayOfWeek+ } deriving (Eq, Ord, Data, Typeable, Show)++instance NFData SundayWeek++{-# INLINE sundayWeek #-}+sundayWeek :: Simple Iso Day SundayWeek+sundayWeek = iso toSunday fromSunday where++ {-# INLINEABLE toSunday #-}+ toSunday :: Day -> SundayWeek+ toSunday = join (toSundayOrdinal . view ordinalDate)++ {-# INLINEABLE fromSunday #-}+ fromSunday :: SundayWeek -> Day+ fromSunday (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd) where+ ModifiedJulianDay firstDay = review ordinalDate (OrdinalDate y 1)+ -- following are all 0-based year days+ firstSunday = mod (4 - firstDay) 7+ yd = firstSunday + 7 * (fromIntegral w - 1) + fromIntegral d++{-# INLINE toSundayOrdinal #-}+toSundayOrdinal :: OrdinalDate -> Day -> SundayWeek+toSundayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) = SundayWeek y+ (fromIntegral $ d7div - div k 7) (fromIntegral d7mod) where+ d = mjd + 3+ k = d - fromIntegral yd+ (d7div, d7mod) = divMod d 7++{-# INLINEABLE sundayWeekValid #-}+sundayWeekValid :: SundayWeek -> Maybe Day+sundayWeekValid (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd)+ <$ guard (0 <= d && d <= 6 && 0 <= yd && yd <= lastDay) where+ ModifiedJulianDay firstDay = review ordinalDate (OrdinalDate y 1)+ -- following are all 0-based year days+ firstSunday = mod (4 - firstDay) 7+ yd = firstSunday + 7 * (fromIntegral w - 1) + fromIntegral d+ lastDay = if isLeapYear y then 365 else 364++------------------------------------------------------------------------++-- | Weeks numbered from 0 to 53, starting with the first Monday of the year+-- as the first day of week 01. The last week of a given year and week 0 of+-- the next both refer to the same week, but not all 'DayOfWeek' are valid.+data MondayWeek = MondayWeek+ { mwYear :: {-# UNPACK #-}!Year+ , mwWeek :: {-# UNPACK #-}!WeekOfYear+ , mwDay :: {-# UNPACK #-}!DayOfWeek+ } deriving (Eq, Ord, Data, Typeable, Show)++instance NFData MondayWeek++{-# INLINE mondayWeek #-}+mondayWeek :: Simple Iso Day MondayWeek+mondayWeek = iso toMonday fromMonday where++ {-# INLINEABLE toMonday #-}+ toMonday :: Day -> MondayWeek+ toMonday = join (toMondayOrdinal . view ordinalDate)++ {-# INLINEABLE fromMonday #-}+ fromMonday :: MondayWeek -> Day+ fromMonday (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd) where+ ModifiedJulianDay firstDay = review ordinalDate (OrdinalDate y 1)+ -- following are all 0-based year days+ firstMonday = mod (5 - firstDay) 7+ yd = firstMonday + 7 * (fromIntegral w - 1) + fromIntegral d - 1++{-# INLINE toMondayOrdinal #-}+toMondayOrdinal :: OrdinalDate -> Day -> MondayWeek+toMondayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) = MondayWeek y+ (fromIntegral $ d7div - div k 7) (fromIntegral $ d7mod + 1) where+ d = mjd + 2+ k = d - fromIntegral yd+ (d7div, d7mod) = divMod d 7++{-# INLINEABLE mondayWeekValid #-}+mondayWeekValid :: MondayWeek -> Maybe Day+mondayWeekValid (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd)+ <$ guard (1 <= d && d <= 7 && 0 <= yd && yd <= lastDay) where+ ModifiedJulianDay firstDay = review ordinalDate (OrdinalDate y 1)+ -- following are all 0-based year days+ firstMonday = mod (5 - firstDay) 7+ yd = firstMonday + 7 * (fromIntegral w - 1) + fromIntegral d - 1+ lastDay = if isLeapYear y then 365 else 364
src/Data/Thyme/Calendar/MonthDay.hs view
@@ -34,7 +34,7 @@ {-# INLINE fromOrdinal #-} fromOrdinal :: DayOfYear -> MonthDay- fromOrdinal yd = (MonthDay m d) where+ fromOrdinal yd = MonthDay m d where (m, d) = T.dayOfYearToMonthAndDay leap yd {-# INLINE toOrdinal #-}
src/Data/Thyme/Calendar/OrdinalDate.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-} -- | ISO 8601 Ordinal Date format @@ -15,42 +16,10 @@ import Data.Thyme.Calendar.Internal import Data.Thyme.TH -{-# INLINE fromOrdinalDateValid #-}-fromOrdinalDateValid :: OrdinalDate -> Maybe Day-fromOrdinalDateValid od@(OrdinalDate y d) = review ordinalDate od+{-# INLINE ordinalDateValid #-}+ordinalDateValid :: OrdinalDate -> Maybe Day+ordinalDateValid od@(OrdinalDate y d) = review ordinalDate od <$ guard (1 <= d && d <= if isLeapYear y then 366 else 365)---- | Use @'review' 'weekDate'@ to convert back to 'Day'.-{-# INLINE sundayStartWeek #-}-sundayStartWeek :: Day -> WeekDate-sundayStartWeek day@(ModifiedJulianDay mjd) = WeekDate y- (fromIntegral $ div d 7 - div k 7) (fromIntegral $ mod d 7) where- OrdinalDate y yd = view ordinalDate day- d = mjd + 3- k = d - fromIntegral yd---- | Accepts 0−6 for 'DayOfWeek', and 0-based 'WeekOfYear's.-{-# INLINEABLE fromSundayStartWeekValid #-}-fromSundayStartWeekValid :: WeekDate -> Maybe Day-fromSundayStartWeekValid wd@(WeekDate y w d) = fromWeekMax wMax wd- <$ guard (0 <= d && d <= 6 && 0 <= w && w <= wMax) where- WeekDate _ wMax _ = view (from ordinalDate . weekDate) (OrdinalDate y 365)---- | Use @'review' 'weekDate'@ to convert back to 'Day'.-{-# INLINE mondayStartWeek #-}-mondayStartWeek :: Day -> WeekDate-mondayStartWeek day@(ModifiedJulianDay mjd) = WeekDate y- (fromIntegral $ div d 7 - div k 7) (fromIntegral $ mod d 7 + 1) where- OrdinalDate y yd = view ordinalDate day- d = mjd + 2- k = d - fromIntegral yd---- | Accepts 1−7 for 'DayOfWeek', and 0-based 'WeekOfYear's.-{-# INLINEABLE fromMondayStartWeekValid #-}-fromMondayStartWeekValid :: WeekDate -> Maybe Day-fromMondayStartWeekValid wd@(WeekDate y w d) = fromWeekMax wMax wd- <$ guard (1 <= d && d <= 7 && 0 <= w && w <= wMax) where- WeekDate _ wMax _ = view (from ordinalDate . weekDate) (OrdinalDate y 365) -- * Lenses thymeLenses ''OrdinalDate
src/Data/Thyme/Calendar/WeekDate.hs view
@@ -1,34 +1,24 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-} --- | ISO 8601 Week Date format+-- | Various Week Date formats module Data.Thyme.Calendar.WeekDate ( Year, WeekOfYear, DayOfWeek- , WeekDate (..), weekDate+ -- * ISO 8601 Week Date+ , WeekDate (..), weekDate, weekDateValid, showWeekDate+ , SundayWeek (..), sundayWeek, sundayWeekValid+ , MondayWeek (..), mondayWeek, mondayWeekValid , module Data.Thyme.Calendar.WeekDate ) where import Prelude-import Control.Applicative-import Control.Lens-import Control.Monad import Data.Thyme.Calendar.OrdinalDate import Data.Thyme.Calendar.Internal import Data.Thyme.TH-import Text.Printf --- | Rejects 0-based 'DayOfWeek' and 'WeekOfYear'.-{-# INLINEABLE fromWeekDateValid #-}-fromWeekDateValid :: WeekDate -> Maybe Day-fromWeekDateValid wd@(WeekDate y w d) = fromWeekMax wMax wd- <$ guard (1 <= d && d <= 7 && 1 <= w && w <= wMax) where- WeekDate _ wMax _ = view (from ordinalDate . weekDate) (OrdinalDate y 365)--{-# INLINEABLE showWeekDate #-}-showWeekDate :: Day -> String-showWeekDate day = printf "%04d-W%02d-%d" y w d where- WeekDate y w d = view weekDate day- -- * Lenses thymeLenses ''WeekDate+thymeLenses ''SundayWeek+thymeLenses ''MondayWeek
src/Data/Thyme/Clock.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Thyme.Clock (@@ -34,7 +33,7 @@ showsPrec p = showsPrec p . view utcTime #else instance Show UTCTime where- showsPrec p = showsPrec p . view (utcLocalTime utc)+ showsPrec p = showsPrec p . view zonedTime . (,) utc #endif getCurrentTime :: IO UTCTime
src/Data/Thyme/Format.hs view
@@ -10,36 +10,39 @@ , formatTime , ParseTime (..) , parseTime+ , TimeParse (..)+ , timeParser ) where import Prelude import Control.Applicative import Control.Lens-import Control.Monad.State.Strict hiding (get)+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as P import Data.Basis import Data.Bits+import qualified Data.ByteString.Builder as S import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy as SL import Data.Char-import Data.Int import Data.Micro import Data.Thyme.Calendar+import Data.Thyme.Calendar.Internal import Data.Thyme.Calendar.MonthDay-import Data.Thyme.Calendar.OrdinalDate-import Data.Thyme.Calendar.WeekDate import Data.Thyme.Clock.POSIX import Data.Thyme.Clock.Scale import Data.Thyme.Clock.UTC import Data.Thyme.Format.Internal import Data.Thyme.LocalTime import Data.Thyme.TH-import qualified Data.Time.Format as T import Data.VectorSpace import System.Locale +type FormatS = Char -> ShowS class FormatTime t where- showsTime :: TimeLocale -> t -> (Char -> ShowS) -> (Char -> ShowS)+ showsTime :: TimeLocale -> t -> FormatS -> FormatS {-# INLINEABLE formatTime #-} formatTime :: (FormatTime t) => TimeLocale -> String -> t -> String@@ -97,25 +100,7 @@ 'Q' -> if su == 0 then id else (:) '.' . fills06 su . drops0 su -- default _ -> def c-- where- (fromIntegral -> si, Micro su) = microQuotRem s (Micro 1000000)-- {-# INLINE fills06 #-}- fills06 :: Int64 -> ShowS- fills06 n- | n < 10 = (++) "00000"- | n < 100 = (++) "0000"- | n < 1000 = (++) "000"- | n < 10000 = (++) "00"- | n < 100000 = (++) "0"- | otherwise = id-- {-# INLINE drops0 #-}- drops0 :: Int64 -> ShowS- drops0 n = case divMod n 10 of- (q, 0) -> drops0 q- _ -> shows n+ where (fromIntegral -> si, Micro su) = microQuotRem s (Micro 1000000) instance FormatTime YearMonthDay where {-# INLINEABLE showsTime #-}@@ -167,37 +152,66 @@ instance FormatTime WeekDate where {-# INLINEABLE showsTime #-} showsTime TimeLocale {..} (WeekDate y w d) = \ def c -> case c of- -- Year (WeekDate)+ -- Year 'G' -> showsYear y 'g' -> shows02 (mod y 100) 'f' -> shows02 (div y 100) -- WeekOfYear 'V' -> shows02 w -- DayOfWeek- 'u' -> shows d+ 'u' -> shows $ if d == 0 then 7 else d+ 'w' -> shows $ if d == 7 then 0 else d 'A' -> (++) . fst $ wDays !! mod d 7 'a' -> (++) . snd $ wDays !! mod d 7- 'w' -> shows (mod d 7) -- default _ -> def c +instance FormatTime SundayWeek where+ {-# INLINEABLE showsTime #-}+ showsTime TimeLocale {..} (SundayWeek y w d) = \ def c -> case c of+ -- Year+ 'Y' -> showsYear y+ 'y' -> shows02 (mod y 100)+ 'C' -> shows02 (div y 100)+ -- WeekOfYear+ 'U' -> shows02 w+ -- DayOfWeek+ 'u' -> shows $ if d == 0 then 7 else d+ 'w' -> shows $ if d == 7 then 0 else d+ 'A' -> (++) . fst $ wDays !! mod d 7+ 'a' -> (++) . snd $ wDays !! mod d 7+ -- default+ _ -> def c++instance FormatTime MondayWeek where+ {-# INLINEABLE showsTime #-}+ showsTime TimeLocale {..} (MondayWeek y w d) = \ def c -> case c of+ -- Year+ 'Y' -> showsYear y+ 'y' -> shows02 (mod y 100)+ 'C' -> shows02 (div y 100)+ -- WeekOfYear+ 'W' -> shows02 w+ -- DayOfWeek+ 'u' -> shows $ if d == 0 then 7 else d+ 'w' -> shows $ if d == 7 then 0 else d+ 'A' -> (++) . fst $ wDays !! mod d 7+ 'a' -> (++) . snd $ wDays !! mod d 7+ -- default+ _ -> def c+ instance FormatTime LocalTime where {-# INLINEABLE showsTime #-} showsTime l (LocalTime day tod) = showsTime l day . showsTime l tod instance FormatTime Day where {-# INLINEABLE showsTime #-}- showsTime l d = showsTime l ordinal- . showsTime l (view yearMonthDay ordinal)- . showsTime l (view weekDate d) . other where- ordinal = view ordinalDate d- other :: (Char -> ShowS) -> (Char -> ShowS)- other def c = case c of- -- Non-standard WeekOfYear- 'U' -> shows02 . wdWeek $ sundayStartWeek d- 'W' -> shows02 . wdWeek $ mondayStartWeek d- -- default- _ -> def c+ showsTime l d@(view ordinalDate -> ordinal)+ = showsTime l ordinal+ . showsTime l (view yearMonthDay ordinal)+ . showsTime l (toWeekOrdinal ordinal d)+ . showsTime l (toSundayOrdinal ordinal d)+ . showsTime l (toMondayOrdinal ordinal d) instance FormatTime TimeZone where {-# INLINEABLE showsTime #-}@@ -227,10 +241,14 @@ data TimeFlag = PostMeridiem+ | TwelveHour | HasCentury | IsPOSIXTime+ | IsOrdinalDate | IsGregorian | IsWeekDate+ | IsSundayWeek+ | IsMondayWeek deriving (Enum, Show) data TimeParse = TimeParse@@ -247,42 +265,23 @@ , tpSecond :: {-# UNPACK #-}!Int , tpSecFrac :: {-# UNPACK #-}!DiffTime , tpPOSIXTime :: {-# UNPACK #-}!POSIXTime- , tpTimeZone :: {-# UNPACK #-}!TimeZone+ , tpTimeZone :: !TimeZone } deriving (Show) thymeLenses ''TimeParse {-# INLINE flag #-} flag :: TimeFlag -> Simple Lens TimeParse Bool-flag (fromEnum -> f@(shiftL 1 -> m@(complement -> m'))) = _tpFlags . lens- (`testBit` f) (\ n b -> if b then n .|. m else n .&. m')--{-# INLINE unixEpoch #-}-unixEpoch :: TimeParse-unixEpoch = TimeParse {..} where- tpCentury = 19- tpCenturyYear = 70- tpMonth = 1- tpWeekOfYear = 1- tpDayOfYear = 1- tpDayOfMonth = 1- tpDayOfWeek = 4- tpFlags = 0- tpHour = 0- tpMinute = 0- tpSecond = 0- tpSecFrac = zeroV- tpPOSIXTime = zeroV- tpTimeZone = utc--{-# INLINEABLE parseTime #-}-parseTime :: (ParseTime t) => TimeLocale -> String -> String -> Maybe t-parseTime l spec = either (const Nothing) Just . P.parseOnly (readsTime l spec) . S.pack+flag (fromEnum -> f) = _tpFlags . lens+ (`testBit` f) (\ n b -> (if b then setBit else clearBit) n f) -{-# INLINEABLE readsTime #-}-readsTime :: (ParseTime t) => TimeLocale -> String -> Parser t-readsTime l@TimeLocale {..} specString = buildTime- <$> execStateT (go specString) unixEpoch where+-- | Time 'Parser' for UTF-8 encoded 'ByteString's.+--+-- Attoparsec easily beats any 'String' parser out there, but we do have to+-- be careful to convert the input to UTF-8 'ByteString's.+{-# INLINEABLE timeParser #-}+timeParser :: TimeLocale -> String -> Parser TimeParse+timeParser TimeLocale {..} = flip execStateT unixEpoch . go where go :: String -> StateT TimeParse Parser () go spec = case spec of@@ -302,8 +301,8 @@ -- Hour 'H' -> lift (dec0 2) >>= setHour24 'I' -> lift (dec0 2) >>= setHour12- 'k' -> lift (dec_ 2) >>= setHour24- 'l' -> lift (dec_ 2) >>= setHour12+ 'k' -> lift (dec_ 2 <|> dec_ 1) >>= setHour24+ 'l' -> lift (dec_ 2 <|> dec_ 1) >>= setHour12 -- Minute 'M' -> lift (dec0 2) >>= assign _tpMinute >> go rspec -- Second@@ -315,45 +314,45 @@ -- Year -- FIXME: should full years / centuries be fixed width? 'Y' -> lift (dec0 4) >>= setYear- 'y' -> lift (dec0 2) >>= assign _tpCenturyYear >> go rspec- 'C' -> lift (dec0 2) >>= assign _tpCentury- >> flag HasCentury .= True >> go rspec-{-+ 'y' -> lift (dec0 2) >>= setCenturyYear+ 'C' -> lift (dec0 2) >>= setCentury -- Month- 'B' -> indexOfCI (fst <$> months) (setMonth . succ)- 'b' -> indexOfCI (snd <$> months) (setMonth . succ)- 'h' -> indexOfCI (snd <$> months) (setMonth . succ)--}+ 'B' -> lift (indexOfCI $ fst <$> months) >>= setMonth . succ+ 'b' -> lift (indexOfCI $ snd <$> months) >>= setMonth . succ+ 'h' -> lift (indexOfCI $ snd <$> months) >>= setMonth . succ 'm' -> lift (dec0 2) >>= setMonth -- DayOfMonth 'd' -> lift (dec0 2) >>= setDayOfMonth- 'e' -> lift (dec_ 2) >>= setDayOfMonth+ 'e' -> lift (dec_ 2 <|> dec_ 1) >>= setDayOfMonth -- DayOfYear- 'j' -> lift (dec0 3) >>= assign _tpDayOfYear >> go rspec+ 'j' -> lift (dec0 3) >>= assign _tpDayOfYear+ >> flag IsOrdinalDate .= True >> go rspec -- Year (WeekDate)- 'G' -> lift (dec0 4) >>= \ y -> flag IsWeekDate .= True >> setYear y- 'g' -> lift (dec0 2) >>= assign _tpCenturyYear- >> flag IsWeekDate .= True >> go rspec- 'f' -> lift (dec0 2) >>= assign _tpCentury- >> flag IsWeekDate .= True >> flag HasCentury .= True >> go rspec+ -- FIXME: problematic if input contains both %Y and %G+ 'G' -> flag IsWeekDate .= True >> lift (dec0 4) >>= setYear+ 'g' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setCenturyYear+ 'f' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setCentury -- WeekOfYear- 'V' -> lift (dec0 2) >>= setWeekOfYear -- ISO 8601- 'U' -> lift (dec0 2) >>= setWeekOfYear -- Sunday start- 'W' -> lift (dec0 2) >>= setWeekOfYear -- Monday start+ -- FIXME: problematic if more than one of the following+ 'V' -> flag IsWeekDate .= True >> lift (dec0 2) >>= setWeekOfYear+ 'U' -> flag IsSundayWeek .= True >> lift (dec0 2) >>= setWeekOfYear+ 'W' -> flag IsMondayWeek .= True >> lift (dec0 2) >>= setWeekOfYear -- DayOfWeek- 'u' -> lift (dec0 1) >>= setDayOfWeek -- ISO 8601- 'w' -> lift (dec0 1) >>= setDayOfWeek -- Sunday start-{- 'A' -> indexOfCI (fst <$> wDays) setDayOfWeek -}-{- 'a' -> indexOfCI (snd <$> wDays) setDayOfWeek -}+ 'w' -> lift (dec0 1) >>= setDayOfWeek+ 'u' -> lift (dec0 1) >>= setDayOfWeek+ 'A' -> lift (indexOfCI $ fst <$> wDays) >>= setDayOfWeek+ 'a' -> lift (indexOfCI $ snd <$> wDays) >>= setDayOfWeek -- TimeZone- 'z' -> timeZone "%z"- 'Z' -> timeZone "%Z"+ 'z' -> do tzOffset; go rspec+ 'Z' -> do tzOffset <|> tzName; go rspec -- UTCTime- 's' -> lift (negative P.decimal) >>= \ s -> flag IsPOSIXTime .= True- >> _tpPOSIXTime .= fromIntegral (s :: Int64) *^ basisValue ()- >> go rspec+ 's' -> do+ s <- lift (negative P.decimal)+ _tpPOSIXTime .= fromIntegral s *^ basisValue ()+ flag IsPOSIXTime .= True+ go rspec -- modifier (whatever) '-' -> go ('%' : rspec)@@ -365,30 +364,84 @@ where dayHalf = do- pm <- lift $ False <$ P.stringCI (S.pack $ fst amPm)- <|> True <$ P.stringCI (S.pack $ snd amPm)+ pm <- lift $ False <$ stringCI (fst amPm)+ <|> True <$ stringCI (snd amPm) flag PostMeridiem .= pm+ flag TwelveHour .= True go rspec- setHour12 h = do _tpHour .= h; go rspec- setHour24 h = do _tpHour .= h; go rspec; flag PostMeridiem .= False- setYear ((`divMod` 100) -> (c, y)) = flag HasCentury .= True- >> _tpCentury .= c >> _tpCenturyYear .= y >> go rspec- setMonth m = _tpMonth .= m >> go rspec- setDayOfMonth d = _tpDayOfMonth .= d- >> flag IsGregorian .= True >> go rspec- setWeekOfYear w = _tpWeekOfYear .= w- >> flag IsWeekDate .= True >> go rspec- setDayOfWeek d = _tpDayOfWeek .= d- >> flag IsWeekDate .= True >> go rspec- -- "time" has a table of zones that we don't care to duplicate- timeZone zspec = {-lift (readS_to_P $ T.readsTime l zspec)- >>= assign _tpTimeZone >> -} go rspec+ setHour12 h = do+ flag TwelveHour .= True+ _tpHour .= h+ go rspec+ setHour24 h = do+ flag TwelveHour .= False+ _tpHour .= h+ go rspec+ setYear ((`divMod` 100) -> (c, y)) = do+ flag HasCentury .= True+ _tpCentury .= c+ _tpCenturyYear .= y+ go rspec+ setCenturyYear y = do _tpCenturyYear .= y; go rspec+ setCentury c = do+ _tpCentury .= c+ flag HasCentury .= True+ go rspec+ setMonth m = do+ flag IsGregorian .= True+ _tpMonth .= m+ go rspec+ setDayOfMonth d = do+ flag IsGregorian .= True+ _tpDayOfMonth .= d+ go rspec+ setWeekOfYear w = do _tpWeekOfYear .= w; go rspec+ setDayOfWeek d = do _tpDayOfWeek .= d; go rspec+ tzOffset = do+ s <- lift (id <$ P.char '+' <|> negate <$ P.char '-')+ h <- lift (dec0 2)+ () <$ lift (P.char ':') <|> pure ()+ m <- lift (dec0 2)+ _tpTimeZone . _timeZoneMinutes .= s (h * 60 + m)+ tzName = lift timeZoneParser >>= assign _tpTimeZone - c : rspec -> case isSpace c of- True -> lift (P.takeWhile1 isSpace) >> go (dropWhile isSpace rspec)- False -> lift (P.char c) >> go rspec+ c : rspec | P.isSpace c ->+ lift (P.takeWhile P.isSpace) >> go (dropWhile P.isSpace rspec)+ c : rspec | isAscii c -> lift (P.char c) >> go rspec+ c : rspec -> lift (charU8 c) >> go rspec "" -> lift P.skipSpace + {-# INLINE micro #-}+ micro :: Parser Micro+ micro = do+ us10 <- either fail return . P.parseOnly P.decimal . S.take 7+ . (`S.append` S.pack "000000") =<< P.takeWhile1 isDigit+ return $ Micro (div (us10 + 5) 10)++ {-# INLINE unixEpoch #-}+ unixEpoch :: TimeParse+ unixEpoch = TimeParse {..} where+ tpCentury = 19+ tpCenturyYear = 70+ tpMonth = 1+ tpWeekOfYear = 1+ tpDayOfYear = 1+ tpDayOfMonth = 1+ tpDayOfWeek = 4+ tpFlags = 0+ tpHour = 0+ tpMinute = 0+ tpSecond = 0+ tpSecFrac = zeroV+ tpPOSIXTime = zeroV+ tpTimeZone = utc++{-# INLINEABLE parseTime #-}+parseTime :: (ParseTime t) => TimeLocale -> String -> String -> Maybe t+parseTime l spec = either (const Nothing) Just+ . P.parseOnly (buildTime <$> timeParser l spec)+ . SL.toStrict . S.toLazyByteString . S.stringUtf8+ class ParseTime t where buildTime :: TimeParse -> t @@ -396,13 +449,16 @@ {-# INLINE buildTime #-} buildTime tp@TimeParse {..} = TimeOfDay h tpMinute (fromIntegral tpSecond *^ basisValue () ^+^ tpSecFrac) where- h = if tp ^. flag PostMeridiem && tpHour < 12- then tpHour + 12 else tpHour+ h = case tp ^. flag TwelveHour of+ False -> tpHour+ True -> case tp ^. flag PostMeridiem of+ False -> mod tpHour 12+ True -> if tpHour < 12 then tpHour + 12 else tpHour {-# INLINE tpYear #-} tpYear :: TimeParse -> Year tpYear tp@TimeParse {..} = tpCenturyYear + 100 * if tp ^. flag HasCentury- then tpCentury else if tpCenturyYear < 70 then 20 else 19+ then tpCentury else if tpCenturyYear < 69 then 20 else 19 instance ParseTime YearMonthDay where {-# INLINE buildTime #-}@@ -418,8 +474,19 @@ instance ParseTime WeekDate where {-# INLINE buildTime #-}- buildTime tp@TimeParse {..} = WeekDate (tpYear tp) tpWeekOfYear tpDayOfWeek+ buildTime tp@TimeParse {..} = WeekDate (tpYear tp) tpWeekOfYear+ (if tpDayOfWeek == 0 then 7 else tpDayOfWeek) +instance ParseTime SundayWeek where+ {-# INLINE buildTime #-}+ buildTime tp@TimeParse {..} = SundayWeek (tpYear tp) tpWeekOfYear+ (if tpDayOfWeek == 7 then 0 else tpDayOfWeek)++instance ParseTime MondayWeek where+ {-# INLINE buildTime #-}+ buildTime tp@TimeParse {..} = MondayWeek (tpYear tp) tpWeekOfYear+ (if tpDayOfWeek == 0 then 7 else tpDayOfWeek)+ instance ParseTime LocalTime where {-# INLINE buildTime #-} buildTime = LocalTime <$> buildTime <*> buildTime@@ -427,9 +494,13 @@ instance ParseTime Day where {-# INLINE buildTime #-} buildTime tp@TimeParse {..}+ | tp ^. flag IsOrdinalDate = review ordinalDate (buildTime tp) | tp ^. flag IsGregorian = review gregorian (buildTime tp) | tp ^. flag IsWeekDate = review weekDate (buildTime tp)+ | tp ^. flag IsSundayWeek = review sundayWeek (buildTime tp)+ | tp ^. flag IsMondayWeek = review mondayWeek (buildTime tp) | otherwise = review ordinalDate (buildTime tp)+ -- TODO: Better conflict handling when multiple flags are set? instance ParseTime TimeZone where {-# INLINE buildTime #-}@@ -444,4 +515,121 @@ buildTime tp@TimeParse {..} = if tp ^. flag IsPOSIXTime then review posixTime tpPOSIXTime else view (from zonedTime . _2) (buildTime tp)++------------------------------------------------------------------------++-- Dubiously pilfered from time-1.4.0.2+-- s/^.*-- \(.*\)\n.*\("[A-Z]\+"\).*"\([+-]\)\([0-9]\{2\}\):\([0-9]\{2\}\)", \(True\|False\).*$/ <|> zone \2 (($\3) \4 \5) \6 -- \1/+-- followed by !sort -r , because some names are prefixes of others.+timeZoneParser :: Parser TimeZone+timeZoneParser++ = zone "ZULU" (($+) 00 00) False -- Same as UTC+ <|> zone "Z" (($+) 00 00) False -- Same as UTC+ <|> zone "YST" (($-) 09 00) False -- Yukon Standard Time+ <|> zone "YDT" (($-) 08 00) True -- Yukon Daylight-Saving Time+ <|> zone "WST" (($+) 08 00) False -- West Australian Standard Time+ <|> zone "WETDST" (($+) 01 00) True -- Western European Daylight-Saving Time+ <|> zone "WET" (($+) 00 00) False -- Western European Time+ <|> zone "WDT" (($+) 09 00) True -- West Australian Daylight-Saving Time+ <|> zone "WAT" (($-) 01 00) False -- West Africa Time+ <|> zone "WAST" (($+) 07 00) False -- West Australian Standard Time+ <|> zone "WADT" (($+) 08 00) True -- West Australian Daylight-Saving Time+ <|> zone "UTC" (($+) 00 00) False -- Universal Coordinated Time+ <|> zone "UT" (($+) 00 00) False -- Universal Time+ <|> zone "TFT" (($+) 05 00) False -- Kerguelen Time+ <|> zone "SWT" (($+) 01 00) False -- Swedish Winter Time+ <|> zone "SST" (($+) 02 00) False -- Swedish Summer Time+ <|> zone "SET" (($+) 01 00) False -- Seychelles Time+ <|> zone "SCT" (($+) 04 00) False -- Mahe Island Time+ <|> zone "SAST" (($+) 09 30) False -- South Australia Standard Time+ <|> zone "SADT" (($+) 10 30) True -- South Australian Daylight-Saving Time+ <|> zone "RET" (($+) 04 00) False -- Reunion Island Time+ <|> zone "PST" (($-) 08 00) False -- Pacific Standard Time+ <|> zone "PDT" (($-) 07 00) True -- Pacific Daylight-Saving Time+ <|> zone "NZT" (($+) 12 00) False -- New Zealand Time+ <|> zone "NZST" (($+) 12 00) False -- New Zealand Standard Time+ <|> zone "NZDT" (($+) 13 00) True -- New Zealand Daylight-Saving Time+ <|> zone "NT" (($-) 11 00) False -- Nome Time+ <|> zone "NST" (($-) 03 30) False -- Newfoundland Standard Time+ <|> zone "NOR" (($+) 01 00) False -- Norway Standard Time+ <|> zone "NFT" (($-) 03 30) False -- Newfoundland Standard Time+ <|> zone "NDT" (($-) 02 30) True -- Newfoundland Daylight-Saving Time+ <|> zone "MVT" (($+) 05 00) False -- Maldives Island Time+ <|> zone "MUT" (($+) 04 00) False -- Mauritius Island Time+ <|> zone "MT" (($+) 08 30) False -- Moluccas Time+ <|> zone "MST" (($-) 07 00) False -- Mountain Standard Time+ <|> zone "MMT" (($+) 06 30) False -- Myanmar Time+ <|> zone "MHT" (($+) 09 00) False -- Kwajalein Time+ <|> zone "MEZ" (($+) 01 00) False -- Mitteleuropaeische Zeit+ <|> zone "MEWT" (($+) 01 00) False -- Middle European Winter Time+ <|> zone "METDST" (($+) 02 00) True -- Middle Europe Daylight-Saving Time+ <|> zone "MET" (($+) 01 00) False -- Middle European Time+ <|> zone "MEST" (($+) 02 00) False -- Middle European Summer Time+ <|> zone "MDT" (($-) 06 00) True -- Mountain Daylight-Saving Time+ <|> zone "MAWT" (($+) 06 00) False -- Mawson (Antarctica) Time+ <|> zone "MART" (($-) 09 30) False -- Marquesas Time+ <|> zone "LIGT" (($+) 10 00) False -- Melbourne, Australia+ <|> zone "KST" (($+) 09 00) False -- Korea Standard Time+ <|> zone "JT" (($+) 07 30) False -- Java Time+ <|> zone "JST" (($+) 09 00) False -- Japan Standard Time, Russia zone 8+ <|> zone "IT" (($+) 03 30) False -- Iran Time+ <|> zone "IST" (($+) 02 00) False -- Israel Standard Time+ <|> zone "IRT" (($+) 03 30) False -- Iran Time+ <|> zone "IOT" (($+) 05 00) False -- Indian Chagos Time+ <|> zone "IDLW" (($-) 12 00) False -- International Date Line, West+ <|> zone "IDLE" (($+) 12 00) False -- International Date Line, East+ <|> zone "HST" (($-) 10 00) False -- Hawaii Standard Time+ <|> zone "HMT" (($+) 03 00) False -- Hellas Mediterranean Time (?)+ <|> zone "HDT" (($-) 09 00) True -- Hawaii/Alaska Daylight-Saving Time+ <|> zone "GST" (($+) 10 00) False -- Guam Standard Time, Russia zone 9+ <|> zone "GMT" (($+) 00 00) False -- Greenwich Mean Time+ <|> zone "FWT" (($+) 02 00) False -- French Winter Time+ <|> zone "FST" (($+) 01 00) False -- French Summer Time+ <|> zone "FNT" (($-) 02 00) False -- Fernando de Noronha Time+ <|> zone "FNST" (($-) 01 00) False -- Fernando de Noronha Summer Time+ <|> zone "EST" (($-) 05 00) False -- Eastern Standard Time+ <|> zone "EETDST" (($+) 03 00) True -- Eastern Europe Daylight-Saving Time+ <|> zone "EET" (($+) 02 00) False -- Eastern European Time, Russia zone 1+ <|> zone "EDT" (($-) 04 00) True -- Eastern Daylight-Saving Time+ <|> zone "EAT" (($+) 03 00) False -- Antananarivo, Comoro Time+ <|> zone "EAST" (($+) 10 00) False -- East Australian Standard Time+ <|> zone "EAST" (($+) 04 00) False -- Antananarivo Summer Time+ <|> zone "DNT" (($+) 01 00) False -- Dansk Normal Tid+ <|> zone "CXT" (($+) 07 00) False -- Christmas (Island) Time+ <|> zone "CST" (($-) 06 00) False -- Central Standard Time+ <|> zone "CETDST" (($+) 02 00) True -- Central European Daylight-Saving Time+ <|> zone "CET" (($+) 01 00) False -- Central European Time+ <|> zone "CEST" (($+) 02 00) False -- Central European Summer Time+ <|> zone "CDT" (($-) 05 00) True -- Central Daylight-Saving Time+ <|> zone "CCT" (($+) 08 00) False -- China Coastal Time+ <|> zone "CAT" (($-) 10 00) False -- Central Alaska Time+ <|> zone "CAST" (($+) 09 30) False -- Central Australia Standard Time+ <|> zone "CADT" (($+) 10 30) True -- Central Australia Daylight-Saving Time+ <|> zone "BT" (($+) 03 00) False -- Baghdad Time+ <|> zone "BST" (($+) 01 00) False -- British Summer Time+ <|> zone "BRT" (($-) 03 00) False -- Brasilia Time+ <|> zone "BRST" (($-) 02 00) False -- Brasilia Summer Time+ <|> zone "BDST" (($+) 02 00) False -- British Double Summer Time+ <|> zone "AWT" (($-) 03 00) False -- (unknown)+ <|> zone "AWST" (($+) 08 00) False -- Australia Western Standard Time+ <|> zone "AWSST" (($+) 09 00) False -- Australia Western Summer Standard Time+ <|> zone "AST" (($-) 04 00) False -- Atlantic Standard Time (Canada)+ <|> zone "ALMT" (($+) 06 00) False -- Almaty Time+ <|> zone "ALMST" (($+) 07 00) False -- Almaty Summer Time+ <|> zone "AKST" (($-) 09 00) False -- Alaska Standard Time+ <|> zone "AKDT" (($-) 08 00) True -- Alaska Daylight-Saving Time+ <|> zone "AHST" (($-) 10 00) False -- Alaska/Hawaii Standard Time+ <|> zone "AFT" (($+) 04 30) False -- Afghanistan Time+ <|> zone "AEST" (($+) 10 00) False -- Australia Eastern Standard Time+ <|> zone "AESST" (($+) 11 00) False -- Australia Eastern Summer Standard Time+ <|> zone "ADT" (($-) 03 00) True -- Atlantic Daylight-Saving Time+ <|> zone "ACT" (($-) 05 00) False -- Atlantic/Porto Acre Standard Time+ <|> zone "ACST" (($-) 04 00) False -- Atlantic/Porto Acre Summer Time+ <|> zone "ACSST" (($+) 10 30) False -- Central Australia Summer Standard Time++ where+ zone name offset dst = TimeZone offset dst name <$ P.string (S.pack name)+ ($+) h m = h * 60 + m+ ($-) h m = negate (h * 60 + m)
src/Data/Thyme/Format/Internal.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE ViewPatterns #-}- module Data.Thyme.Format.Internal where import Prelude@@ -7,9 +5,10 @@ import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Builder as S+import qualified Data.ByteString.Lazy as L import Data.Char import Data.Int-import Data.Micro {-# INLINE shows02 #-} shows02 :: Int -> String -> String@@ -34,37 +33,62 @@ | n < 1000 = (++) "0" . shows n | otherwise = shows n +{-# INLINE fills06 #-}+fills06 :: Int64 -> ShowS+fills06 n+ | n < 10 = (++) "00000"+ | n < 100 = (++) "0000"+ | n < 1000 = (++) "000"+ | n < 10000 = (++) "00"+ | n < 100000 = (++) "0"+ | otherwise = id++{-# INLINE drops0 #-}+drops0 :: Int64 -> ShowS+drops0 n = case divMod n 10 of+ (q, 0) -> drops0 q+ _ -> shows n+ ------------------------------------------------------------------------ -{--{-# INLINEABLE indexOfCI #-}-indexOfCI :: (Alternative m, Monad m) =>- [String] -> (Int -> String -> m k) -> (String -> m k)-indexOfCI l k input = uncurry k =<< foldr (<|>) no (zipWith match l [0..]) where- match s i = stringCI s (return . (,) i) input- no = fail $ "Expected month at " ++ show input--}+{-# INLINE indexOfCI #-}+indexOfCI :: [String] -> Parser Int+indexOfCI = P.choice . zipWith (\ i s -> i <$ stringCI s) [0..] +-- | Case-insensitive UTF-8 ByteString parser+--+-- Matches one character at a time. Slow.+{-# INLINE stringCI #-}+stringCI :: String -> Parser ()+stringCI = foldl (\ p c -> p *> charCI c) (pure ())++-- | Case-insensitive UTF-8 ByteString parser+--+-- We can't easily perform upper/lower case conversion on the input, so+-- instead we accept either one of @toUpper c@ and @toLower c@.+{-# INLINE charCI #-}+charCI :: Char -> Parser ()+charCI c = if u == l then charU8 c else charU8 l <|> charU8 u where+ l = toLower c+ u = toUpper c++{-# INLINE charU8 #-}+charU8 :: Char -> Parser ()+charU8 c = () <$ P.string (L.toStrict . S.toLazyByteString . S.charUtf8 $ c)+ -- | Number may be prefixed with '-' {-# INLINE negative #-} negative :: Parser Int64 -> Parser Int64 negative p = ($) <$> (negate <$ P.char '-' <|> pure id) <*> p -- | Fixed-length 0-padded decimal-{-# INLINEABLE dec0 #-}+{-# INLINE dec0 #-} dec0 :: Int -> Parser Int dec0 n = either fail return . P.parseOnly P.decimal =<< P.take n -- | Fixed-length space-padded decimal-{-# INLINEABLE dec_ #-}+{-# INLINE dec_ #-} dec_ :: Int -> Parser Int dec_ n = either fail return . P.parseOnly P.decimal =<< S.dropWhile isSpace <$> P.take n--{-# INLINEABLE micro #-}-micro :: Parser Micro-micro = do- us10 <- either fail return . P.parseOnly P.decimal . S.take 7- . (`S.append` S.pack "000000") =<< P.takeWhile1 isDigit- return $ Micro (div (us10 + 5) 10)
src/Data/Thyme/LocalTime.hs view
@@ -11,31 +11,10 @@ import Prelude import Control.Lens-import Data.Data import Data.Thyme.Clock import Data.Thyme.LocalTime.Internal import Data.Thyme.LocalTime.TimeZone import Data.Thyme.TH----------------------------------------------------------------------------- * Zoned Time--data ZonedTime = ZonedTime- { zonedTimeToLocalTime :: {-only 4 words…-} {-# UNPACK #-}!LocalTime- , zonedTimeZone :: !TimeZone- } deriving (Eq, Ord, Data, Typeable, Show)--{-# INLINE zonedTime #-}-zonedTime :: Simple Iso (TimeZone, UTCTime) ZonedTime-zonedTime = iso toZoned fromZoned where-- {-# INLINE toZoned #-}- toZoned :: (TimeZone, UTCTime) -> ZonedTime- toZoned (tz, time) = ZonedTime (view (utcLocalTime tz) time) tz-- {-# INLINE fromZoned #-}- fromZoned :: ZonedTime -> (TimeZone, UTCTime)- fromZoned (ZonedTime lt tz) = (tz, review (utcLocalTime tz) lt) {-# INLINE getZonedTime #-} getZonedTime :: IO ZonedTime
src/Data/Thyme/LocalTime/Internal.hs view
@@ -9,7 +9,7 @@ import Prelude hiding ((.)) import Control.Applicative-import Control.Category+import Control.Category hiding (id) import Control.Lens import Control.Monad import Data.AffineSpace@@ -40,8 +40,10 @@ #else instance Show TimeOfDay where showsPrec _ (TimeOfDay h m (DiffTime s))- = shows02 h . (:) ':' . shows02 m . (:) ':'- . shows02 (fromIntegral . fst . microQuotRem s $ Micro 1000000)+ = shows02 h . (:) ':' . shows02 m . (:) ':'+ . shows02 (fromIntegral si) . frac where+ (si, Micro su) = microQuotRem s (Micro 1000000)+ frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su #endif {-# INLINE makeTimeOfDayValid #-}@@ -83,7 +85,7 @@ NominalDiffTime posixDay = posixDayLength fromRatio :: Rational -> DiffTime- fromRatio r = DiffTime (r *^ posixDay) where+ fromRatio r = DiffTime (r *^ posixDay) toRatio :: DiffTime -> Rational toRatio (DiffTime t) = t ^/^ posixDay@@ -119,4 +121,31 @@ (dd, utcToD) = addMinutes (negate timeZoneMinutes) tod -- TODO: ut1LocalTime++------------------------------------------------------------------------+-- * Zoned Time++data ZonedTime = ZonedTime+ { zonedTimeToLocalTime :: {-only 4 words…-} {-# UNPACK #-}!LocalTime+ , zonedTimeZone :: !TimeZone+ } deriving (Eq, Ord, Data, Typeable)++{-# INLINE zonedTime #-}+zonedTime :: Simple Iso (TimeZone, UTCTime) ZonedTime+zonedTime = iso toZoned fromZoned where++ {-# INLINE toZoned #-}+ toZoned :: (TimeZone, UTCTime) -> ZonedTime+ toZoned (tz, time) = ZonedTime (view (utcLocalTime tz) time) tz++ {-# INLINE fromZoned #-}+ fromZoned :: ZonedTime -> (TimeZone, UTCTime)+ fromZoned (ZonedTime lt tz) = (tz, review (utcLocalTime tz) lt)++#if SHOW_INTERNAL+deriving instance Show ZonedTime+#else+instance Show ZonedTime where+ showsPrec p (ZonedTime lt tz) = showsPrec p lt . (:) ' ' . showsPrec p tz+#endif
tests/sanity.hs view
@@ -7,14 +7,16 @@ import Control.Applicative import Control.Lens import Control.Monad-import Control.Monad.Trans+import Control.Monad.IO.Class import Criterion import Criterion.Analysis import Criterion.Config import Criterion.Environment import Criterion.Monad+import qualified Data.Attoparsec.ByteString.Char8 as P import Data.Basis-import Data.List+import qualified Data.ByteString.Builder as S+import qualified Data.ByteString.Lazy as SL import Data.Monoid import Data.Thyme import qualified Data.Time as T@@ -28,7 +30,8 @@ instance Arbitrary Day where arbitrary = fmap (review gregorian) $ YearMonthDay- <$> choose (0, 9999) <*> choose (1, 12) <*> choose (1, 31)+ -- FIXME: We disagree with time on how many digits to use for year.+ <$> choose (1000, 9999) <*> choose (1, 12) <*> choose (1, 31) instance Arbitrary DiffTime where arbitrary = (^*) (basisValue ()) . toRational <$> (choose (0, 86400.999999) :: Gen Double)@@ -48,12 +51,41 @@ newtype Spec = Spec String deriving (Show) instance Arbitrary Spec where- arbitrary = fmap (Spec . intercalate " " . map (\ c -> ['%', c]))- . Gen.listOf1 . Gen.elements . nub $- {-aggregate/escape-}"crXx%" ++ {-TimeOfDay-}"RTPpHIklMSqQ" ++- {-YearMonthDay-}"DFYyCBbhmde" ++ {-MonthDay-}"Bbhmde" ++- {-OrdinalDate-}"YyCj" ++ {-WeekDate-}"GgfVuAaw" ++- {-Day-}"UW" ++ {-TimeZone-}"zZ" ++ {-UTCTime-}"s"+ arbitrary = do+ -- Pick a non-overlapping day spec generator.+ day <- Gen.elements+ [ spec {-YearMonthDay-}"DFYyCBbhmde"+ , spec {-OrdinalDate-}"YyCj"+ -- TODO: time only consider the presence of %V as+ -- indication that it should parse as WeekDate+ , (++) "%V " <$> spec {-WeekDate-}"GgfuwAa"+ , spec {-SundayWeek-}"YyCUuwAa"+ , spec {-MondayWeek-}"YyCWuwAa"+ ] :: Gen (Gen String)+ -- Pick a non-overlapping day & tod spec generator.+ time <- Gen.frequency+ [ (16, pure $ Gen.frequency+ [ (8, day)+ , (4, rod)+ , (2, h12)+ , (1, sec)+ , (1, spec {-TimeZone-}"zZ")+ ] )+ -- TODO: these are broken due to issues above and below+ -- , (2, pure $ spec {-aggregate-}"crXx")+ , (1, pure $ spec {-UTCTime-}"s")+ ] :: Gen (Gen String)+ fmap (Spec . unwords) . listOf1 $ frequency+ [(16, time), (4, string), (1, pure "%%")]+ where+ spec = Gen.elements . fmap (\ c -> ['%', c])+ string = filter ('%' /=) <$> arbitrary+ -- TODO: time discards %q %Q or %p %P after setting %S or hours+ -- respectively. Fudge it by always including %q and %p at end.+ -- tod = spec {-TimeOfDay-}"RTPpHIklMSqQ"+ rod = spec {-RestOfDay-}"RHkMqQ"+ sec = (++ " %q") <$> spec {-seconds-}"ST"+ h12 = (++ " %p") <$> spec {-12-hour-}"Il" ------------------------------------------------------------------------ @@ -69,7 +101,10 @@ = printTestCase desc (fmap toTime t == t') where t = parseTime defaultTimeLocale spec s t' = T.parseTime defaultTimeLocale spec s- desc = "input: " ++ s ++ "\nthyme: " ++ show t ++ "\ntime: " ++ show t'+ tp = P.parseOnly (timeParser defaultTimeLocale spec)+ . SL.toStrict . S.toLazyByteString . S.stringUtf8+ desc = "input: " ++ show s ++ "\nthyme: " ++ show t+ ++ "\ntime: " ++ show t' ++ "\nstate: " ++ show (tp s) ------------------------------------------------------------------------ @@ -90,7 +125,7 @@ ( "formatTime", 9 , nf (formatTime defaultTimeLocale spec <$>) ts , nf (T.formatTime defaultTimeLocale spec <$>) ts' ) :- ("parseTime", 5, nf (parse <$>) ss, nf (parse' <$>) ss ) :+ ( "parseTime", 4.5, nf (parse <$>) ss, nf (parse' <$>) ss ) : [] exitWith $ if correct && fast then ExitSuccess else ExitFailure 1@@ -98,7 +133,7 @@ isSuccess r = case r of Success {} -> True; _ -> False config = defaultConfig {cfgVerbosity = Last (Just Quiet)} - spec = "%F %G %V %u %j %T %p %s"+ spec = "%F %G %V %u %j %T %s" parse = parseTime defaultTimeLocale spec :: String -> Maybe UTCTime parse' = T.parseTime defaultTimeLocale spec :: String -> Maybe T.UTCTime
thyme.cabal view
@@ -1,5 +1,5 @@ name: thyme-version: 0.1.2.0+version: 0.2.0.0 synopsis: A faster time library description: A faster time library@@ -18,18 +18,26 @@ type: git location: http://github.com/liyang/thyme -flag instance-num- description: instance Num (Nominal)DiffTime- default: True- flag bug-for-bug description: bug-for-bug compatibility with time default: True+ manual: True +flag instance-num+ description: instance Num (Nominal)DiffTime+ default: True+ manual: True+ flag show-internal description: instance Show of internal representation default: False+ manual: True +flag Werror+ description: -Werror+ default: False+ manual: True+ library hs-source-dirs: src exposed-modules:@@ -53,22 +61,24 @@ Data.Thyme.TH build-depends: base >= 4.5 && < 5,- mtl >= 2.1,+ transformers >= 0.3, deepseq >= 1.2, vector-space >= 0.8, lens >= 3.7, old-locale >= 1.0, template-haskell >= 2.6,- bytestring >= 0.10,+ bytestring >= 0.10.2, attoparsec >= 0.10, time >= 1.4 ghc-options: -Wall- if flag(instance-num)- cpp-options: -DINSTANCE_NUM=1 if flag(bug-for-bug) cpp-options: -DBUG_FOR_BUG=1+ if flag(instance-num)+ cpp-options: -DINSTANCE_NUM=1 if flag(show-internal) cpp-options: -DSHOW_INTERNAL=1+ if flag(Werror)+ ghc-options: -Werror test-suite sanity type: exitcode-stdio-1.0@@ -76,11 +86,12 @@ main-is: sanity.hs build-depends: base >= 4.5 && < 5,- mtl >= 2.1,- deepseq >= 1.2,+ transformers >= 0.3, vector-space >= 0.8, lens >= 3.7, old-locale >= 1.0,+ bytestring >= 0.10.2,+ attoparsec >= 0.10, random >= 1.0, QuickCheck >= 2.4, criterion >= 0.6,