diff --git a/src/Data/Micro.hs b/src/Data/Micro.hs --- a/src/Data/Micro.hs +++ b/src/Data/Micro.hs @@ -15,22 +15,41 @@ import Data.Int import Data.Ix import Data.Ratio +import Data.VectorSpace + #if !SHOW_INTERNAL +import Control.Monad +import Data.Char import Data.Thyme.Format.Internal +import Numeric +import Text.ParserCombinators.ReadPrec +import Text.ParserCombinators.ReadP +import Text.Read #endif -import Data.VectorSpace newtype Micro = Micro Int64 deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable) #if SHOW_INTERNAL deriving instance Show Micro +deriving instance Read Micro #else instance Show Micro where 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 + +instance Read Micro where + readPrec = lift $ do + sign <- char '-' >> return negate `mplus` return id + s <- readS_to_P readDec + us <- (`mplus` return 0) $ do + _ <- char '.' + [(us10, "")] <- (readDec . take 7 . (++ "000000")) + `fmap` munch1 isDigit + return (div (us10 + 5) 10) + return . Micro . sign $ s * 1000000 + us #endif {-# INLINE toMicro #-} diff --git a/src/Data/Thyme.hs b/src/Data/Thyme.hs --- a/src/Data/Thyme.hs +++ b/src/Data/Thyme.hs @@ -1,3 +1,29 @@ +-- | Thyme is a rewrite of the fine @time@ library, with a particular focus +-- on performance for applications that make heavy use of timestamps. For +-- example, 'UTCTime' is represented with μs precision as an +-- 'Data.Int.Int64', which gives a usable range from @-290419-11-07 +-- 19:59:05.224192 UTC@ to @294135-11-26 04:00:54.775807 UTC@ in the future. +-- +-- Conversions are provided as 'Control.Lens.Iso''s from the @lens@ package, +-- while 'Data.AdditiveGroup.AdditiveGroup', 'Data.VectorSpace.VectorSpace' +-- and 'Data.AffineSpace.AffineSpace' from @vector-space@ allow for more +-- principled calculations instead of 'Num', 'Fractional' & al. Check each +-- module for usage examples, and see +-- or +-- for further details. +-- +-- Thyme uses strict and unpacked tuples throughout, e.g. 'YearMonthDay' or +-- 'Data.Thyme.Calendar.WeekDate.WeekDate'. Descriptive 'Int' synonyms such +-- as 'Year' and 'DayOfMonth' are also provided. +-- +-- On platforms where 'Int' is 64-bits wide, types with an 'Enum' instance +-- can be used as 'Data.IntMap.Key's for 'Data.IntMap.IntMap', preferably +-- via the @EnumMap@ wrapper provided by +-- . In any case the 'Ord' +-- instances are much faster, if you must use 'Data.Map.Map'. +-- +-- "Data.Thyme.Time" is a drop-in compatibility module for exising code. + module Data.Thyme ( module Data.Thyme.Calendar , module Data.Thyme.Clock diff --git a/src/Data/Thyme/Calendar.hs b/src/Data/Thyme/Calendar.hs --- a/src/Data/Thyme/Calendar.hs +++ b/src/Data/Thyme/Calendar.hs @@ -25,7 +25,7 @@ import Data.Thyme.TH {-# INLINE yearMonthDay #-} -yearMonthDay :: Simple Iso OrdinalDate YearMonthDay +yearMonthDay :: Iso' OrdinalDate YearMonthDay yearMonthDay = iso fromOrdinal toOrdinal where {-# INLINEABLE fromOrdinal #-} @@ -39,7 +39,7 @@ review (monthDay (isLeapYear y)) (MonthDay m d) {-# INLINE gregorian #-} -gregorian :: Simple Iso Day YearMonthDay +gregorian :: Iso' Day YearMonthDay gregorian = ordinalDate . yearMonthDay {-# INLINEABLE gregorianValid #-} diff --git a/src/Data/Thyme/Calendar/Internal.hs b/src/Data/Thyme/Calendar/Internal.hs --- a/src/Data/Thyme/Calendar/Internal.hs +++ b/src/Data/Thyme/Calendar/Internal.hs @@ -65,7 +65,7 @@ instance NFData OrdinalDate {-# INLINE ordinalDate #-} -ordinalDate :: Simple Iso Day OrdinalDate +ordinalDate :: Iso' Day OrdinalDate ordinalDate = iso toOrd fromOrd where {-# INLINEABLE toOrd #-} @@ -108,7 +108,7 @@ instance NFData WeekDate {-# INLINE weekDate #-} -weekDate :: Simple Iso Day WeekDate +weekDate :: Iso' Day WeekDate weekDate = iso toWeek fromWeek where {-# INLINEABLE toWeek #-} @@ -175,7 +175,7 @@ instance NFData SundayWeek {-# INLINE sundayWeek #-} -sundayWeek :: Simple Iso Day SundayWeek +sundayWeek :: Iso' Day SundayWeek sundayWeek = iso toSunday fromSunday where {-# INLINEABLE toSunday #-} @@ -223,7 +223,7 @@ instance NFData MondayWeek {-# INLINE mondayWeek #-} -mondayWeek :: Simple Iso Day MondayWeek +mondayWeek :: Iso' Day MondayWeek mondayWeek = iso toMonday fromMonday where {-# INLINEABLE toMonday #-} diff --git a/src/Data/Thyme/Calendar/MonthDay.hs b/src/Data/Thyme/Calendar/MonthDay.hs --- a/src/Data/Thyme/Calendar/MonthDay.hs +++ b/src/Data/Thyme/Calendar/MonthDay.hs @@ -28,7 +28,7 @@ -- | Convert between day of year in the Gregorian or Julian calendars, and -- month and day of month. First arg is leap year flag. {-# INLINE monthDay #-} -monthDay :: Bool -> Simple Iso DayOfYear MonthDay +monthDay :: Bool -> Iso' DayOfYear MonthDay monthDay leap = iso fromOrdinal toOrdinal where -- TODO: Calls non-inlineable code from @time@. Pilfer and optimise? diff --git a/src/Data/Thyme/Calendar/WeekdayOfMonth.hs b/src/Data/Thyme/Calendar/WeekdayOfMonth.hs --- a/src/Data/Thyme/Calendar/WeekdayOfMonth.hs +++ b/src/Data/Thyme/Calendar/WeekdayOfMonth.hs @@ -26,7 +26,7 @@ instance NFData WeekdayOfMonth {-# INLINE weekdayOfMonth #-} -weekdayOfMonth :: Simple Iso Day WeekdayOfMonth +weekdayOfMonth :: Iso' Day WeekdayOfMonth weekdayOfMonth = iso toWeekday fromWeekday where {-# INLINEABLE toWeekday #-} diff --git a/src/Data/Thyme/Clock.hs b/src/Data/Thyme/Clock.hs --- a/src/Data/Thyme/Clock.hs +++ b/src/Data/Thyme/Clock.hs @@ -8,13 +8,13 @@ -- * Absolute intervals , DiffTime - , microsecondsToDiffTime + , microDiffTime -- * UTC , UTCTime, UTCView (..) , utcTime , NominalDiffTime - , microsecondsToNominalDiffTime + , microNominalDiffTime , module Data.Thyme.Clock -- * Lenses diff --git a/src/Data/Thyme/Clock/Internal.hs b/src/Data/Thyme/Clock/Internal.hs --- a/src/Data/Thyme/Clock/Internal.hs +++ b/src/Data/Thyme/Clock/Internal.hs @@ -21,14 +21,24 @@ import Data.Thyme.Calendar import Data.VectorSpace +#if !SHOW_INTERNAL +import Control.Monad +import Text.ParserCombinators.ReadPrec (lift) +import Text.ParserCombinators.ReadP (char) +import Text.Read (readPrec) +#endif + newtype DiffTime = DiffTime Micro deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup) #if SHOW_INTERNAL deriving instance Show DiffTime +deriving instance Read DiffTime #else instance Show DiffTime where - showsPrec p (DiffTime a) rest = showsPrec p a ('s' : rest) + showsPrec p (DiffTime a) = showsPrec p a . (:) 's' +instance Read DiffTime where + readPrec = return (const . DiffTime) `ap` readPrec `ap` lift (char 's') #endif instance VectorSpace DiffTime where @@ -52,9 +62,9 @@ deriving instance RealFrac DiffTime #endif -{-# INLINE microsecondsToDiffTime #-} -microsecondsToDiffTime :: Int64 -> DiffTime -microsecondsToDiffTime = DiffTime . Micro +{-# INLINE microDiffTime #-} +microDiffTime :: Iso' Int64 DiffTime +microDiffTime = iso (DiffTime . Micro) (\ (DiffTime (Micro u)) -> u) ------------------------------------------------------------------------ @@ -63,9 +73,12 @@ #if SHOW_INTERNAL deriving instance Show NominalDiffTime +deriving instance Read NominalDiffTime #else instance Show NominalDiffTime where showsPrec p (NominalDiffTime a) rest = showsPrec p a ('s' : rest) +instance Read NominalDiffTime where + readPrec = return (const . NominalDiffTime) `ap` readPrec `ap` lift (char 's') #endif instance VectorSpace NominalDiffTime where @@ -89,9 +102,10 @@ deriving instance RealFrac NominalDiffTime #endif -{-# INLINE microsecondsToNominalDiffTime #-} -microsecondsToNominalDiffTime :: Int64 -> NominalDiffTime -microsecondsToNominalDiffTime = NominalDiffTime . Micro +{-# INLINE microNominalDiffTime #-} +microNominalDiffTime :: Iso' Int64 NominalDiffTime +microNominalDiffTime = iso (NominalDiffTime . Micro) + (\ (NominalDiffTime (Micro u)) -> u) {-# INLINE posixDayLength #-} posixDayLength :: NominalDiffTime @@ -103,7 +117,7 @@ deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable) {-# INLINE modJulianDate #-} -modJulianDate :: Simple Iso UniversalTime Rational +modJulianDate :: Iso' UniversalTime Rational modJulianDate = iso (\ (UniversalRep t) -> t ^/^ posixDayLength) (UniversalRep . (*^ posixDayLength)) @@ -120,10 +134,10 @@ instance NFData UTCView -_utctDay :: Simple Lens UTCTime Day +_utctDay :: Lens' UTCTime Day _utctDay = utcTime . lens utctDay (\ (UTCTime _ t) d -> UTCTime d t) -_utctDayTime :: Simple Lens UTCTime DiffTime +_utctDayTime :: Lens' UTCTime DiffTime _utctDayTime = utcTime . lens utctDayTime (\ (UTCTime d _) t -> UTCTime d t) instance AffineSpace UTCTime where @@ -134,7 +148,7 @@ UTCRep a .+^ d = UTCRep (a ^+^ d) {-# INLINE utcTime #-} -utcTime :: Simple Iso UTCTime UTCView +utcTime :: Iso' UTCTime UTCView utcTime = iso toView fromView where NominalDiffTime posixDay@(Micro uPosixDay) = posixDayLength diff --git a/src/Data/Thyme/Clock/POSIX.hs b/src/Data/Thyme/Clock/POSIX.hs --- a/src/Data/Thyme/Clock/POSIX.hs +++ b/src/Data/Thyme/Clock/POSIX.hs @@ -14,7 +14,7 @@ type POSIXTime = NominalDiffTime {-# INLINE posixTime #-} -posixTime :: Simple Iso UTCTime POSIXTime +posixTime :: Iso' UTCTime POSIXTime posixTime = iso (\ (UTCRep t) -> t ^-^ unixEpoch) (UTCRep . (^+^) unixEpoch) where unixEpoch = {-ModifiedJulianDay-}40587 *^ posixDayLength diff --git a/src/Data/Thyme/Clock/TAI.hs b/src/Data/Thyme/Clock/TAI.hs --- a/src/Data/Thyme/Clock/TAI.hs +++ b/src/Data/Thyme/Clock/TAI.hs @@ -72,7 +72,7 @@ NominalDiffTime posixDay = posixDayLength {-# INLINE absoluteTime #-} -absoluteTime :: LeapSecondTable -> Simple Iso UTCTime AbsoluteTime +absoluteTime :: LeapSecondTable -> Iso' UTCTime AbsoluteTime absoluteTime table = iso toTAI fromTAI where {-# INLINE toTAI #-} @@ -138,8 +138,9 @@ {-# INLINEABLE micro #-} micro :: Parser Micro micro = do - s <- P.decimal <* P.string "." + sign <- negate <$ P.char '-' <|> pure id + s <- P.decimal <* P.char '.' us10 <- either fail return . P.parseOnly P.decimal . S.take 7 . (`S.append` S.pack "000000") =<< P.takeWhile1 P.isDigit - return $ Micro (s * 1000000 + div (us10 + 5) 10) + return . Micro . sign $ s * 1000000 + div (us10 + 5) 10 diff --git a/src/Data/Thyme/Format.hs b/src/Data/Thyme/Format.hs --- a/src/Data/Thyme/Format.hs +++ b/src/Data/Thyme/Format.hs @@ -11,6 +11,7 @@ , ParseTime (..) , parseTime , readTime + , readsTime , TimeParse (..) , timeParser ) where @@ -279,7 +280,7 @@ thymeLenses ''TimeParse {-# INLINE flag #-} -flag :: TimeFlag -> Simple Lens TimeParse Bool +flag :: TimeFlag -> Lens' TimeParse Bool flag (fromEnum -> f) = _tpFlags . lens (`testBit` f) (\ n b -> (if b then setBit else clearBit) n f) @@ -453,6 +454,39 @@ readTime :: (ParseTime t) => TimeLocale -> String -> String -> t readTime l spec = either error id . P.parseOnly (buildTime <$> timeParser l spec) . utf8String + +{-# INLINEABLE readsTime #-} +readsTime :: (ParseTime t) => TimeLocale -> String -> ReadS t +readsTime l spec = parserToReadS (buildTime <$> timeParser l spec) + +------------------------------------------------------------------------ + +instance Read Day where + {-# INLINEABLE readsPrec #-} + readsPrec _ = readParen False $ + readsTime defaultTimeLocale "%Y-%m-%d" + +instance Read TimeOfDay where + {-# INLINEABLE readsPrec #-} + readsPrec _ = readParen False $ + readsTime defaultTimeLocale "%H:%M:%S%Q" + +instance Read LocalTime where + {-# INLINEABLE readsPrec #-} + readsPrec _ = readParen False $ + readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q" + +instance Read ZonedTime where + {-# INLINEABLE readsPrec #-} + readsPrec _ = readParen False $ + readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q %Z" + +instance Read UTCTime where + {-# INLINEABLE readsPrec #-} + readsPrec _ = readParen False $ + readsTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q %Z" + +------------------------------------------------------------------------ class ParseTime t where buildTime :: TimeParse -> t diff --git a/src/Data/Thyme/Format/Internal.hs b/src/Data/Thyme/Format/Internal.hs --- a/src/Data/Thyme/Format/Internal.hs +++ b/src/Data/Thyme/Format/Internal.hs @@ -1,14 +1,17 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} module Data.Thyme.Format.Internal where import Prelude import Control.Applicative -import Data.Attoparsec.ByteString.Char8 (Parser) +import Data.Attoparsec.ByteString.Char8 (Parser, Result, IResult (..)) import qualified Data.Attoparsec.ByteString.Char8 as P import qualified Data.ByteString.Char8 as S import Data.Char import Data.Int +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text #if MIN_VERSION_bytestring(0,10,0) # if MIN_VERSION_bytestring(0,10,2) @@ -17,8 +20,6 @@ import qualified Data.ByteString.Lazy.Builder as B # endif import qualified Data.ByteString.Lazy as L -#else -import qualified Data.ByteString.UTF8 as U8 #endif {-# INLINE utf8Char #-} @@ -29,8 +30,8 @@ utf8Char = L.toStrict . B.toLazyByteString . B.charUtf8 utf8String = L.toStrict . B.toLazyByteString . B.stringUtf8 #else -utf8Char = U8.fromString . (:[]) -utf8String = U8.fromString +utf8Char = Text.encodeUtf8 . Text.singleton +utf8String = Text.encodeUtf8 . Text.pack #endif ------------------------------------------------------------------------ @@ -52,11 +53,12 @@ {-# INLINE shows04 #-} shows04 :: Int -> String -> String -shows04 n - | n < 10 = (++) "000" . shows n - | n < 100 = (++) "00" . shows n - | n < 1000 = (++) "0" . shows n - | otherwise = shows n +shows04 n@(abs -> u) + | u < 10 = neg . (++) "000" . shows n + | u < 100 = neg . (++) "00" . shows n + | u < 1000 = neg . (++) "0" . shows n + | otherwise = neg . shows u + where neg = if n < 0 then (:) '-' else id {-# INLINE fills06 #-} fills06 :: Int64 -> ShowS @@ -75,6 +77,22 @@ _ -> shows n ------------------------------------------------------------------------ + +{-# INLINEABLE parserToReadS #-} +parserToReadS :: Parser a -> ReadS a +parserToReadS = go . P.parse where + {-# INLINEABLE go #-} + go :: (S.ByteString -> Result a) -> ReadS a + go k (splitAt 32 -> (h, t)) = case k (utf8String h) of + -- `date -R | wc -c` is 32 characters + Fail rest cxts msg -> fail $ concat [ "parserToReadS: ", msg + , "; remaining: ", show (utf8Decode rest), "; stack: ", show cxts ] + Partial k' -> go k' t + Done rest a -> return (a, utf8Decode rest ++ t) + + {-# INLINE utf8Decode #-} + utf8Decode :: S.ByteString -> String + utf8Decode = Text.unpack . Text.decodeUtf8 {-# INLINE indexOf #-} indexOf :: [String] -> Parser Int diff --git a/src/Data/Thyme/LocalTime/Internal.hs b/src/Data/Thyme/LocalTime/Internal.hs --- a/src/Data/Thyme/LocalTime/Internal.hs +++ b/src/Data/Thyme/LocalTime/Internal.hs @@ -10,6 +10,7 @@ import Prelude hiding ((.)) import Control.Applicative import Control.Category hiding (id) +import Control.DeepSeq import Control.Lens import Control.Monad import Data.AffineSpace @@ -34,6 +35,8 @@ , todSec :: {-# UNPACK #-}!DiffTime } deriving (Eq, Ord, Data, Typeable) +instance NFData TimeOfDay + #if SHOW_INTERNAL deriving instance Show TimeOfDay #else @@ -60,7 +63,7 @@ <* guard (Micro 0 <= u && u < Micro 61000000) {-# INLINE timeOfDay #-} -timeOfDay :: Simple Iso DiffTime TimeOfDay +timeOfDay :: Iso' DiffTime TimeOfDay timeOfDay = iso fromDiff toDiff where {-# INLINEABLE fromDiff #-} @@ -86,7 +89,7 @@ (dh, m') = divMod (m + dm) 60 {-# INLINE dayFraction #-} -dayFraction :: Simple Iso TimeOfDay Rational +dayFraction :: Iso' TimeOfDay Rational dayFraction = from timeOfDay . iso toRatio fromRatio where NominalDiffTime posixDay = posixDayLength @@ -104,6 +107,8 @@ , localTimeOfDay :: {-only 3 words…-} {-# UNPACK #-}!TimeOfDay } deriving (Eq, Ord, Data, Typeable) +instance NFData LocalTime + #if SHOW_INTERNAL deriving instance Show LocalTime #else @@ -112,7 +117,7 @@ #endif {-# INLINE utcLocalTime #-} -utcLocalTime :: TimeZone -> Simple Iso UTCTime LocalTime +utcLocalTime :: TimeZone -> Iso' UTCTime LocalTime utcLocalTime TimeZone {..} = utcTime . iso localise globalise where {-# INLINEABLE localise #-} @@ -127,7 +132,7 @@ (dd, utcToD) = addMinutes (negate timeZoneMinutes) tod {-# INLINE ut1LocalTime #-} -ut1LocalTime :: Rational -> Simple Iso UniversalTime LocalTime +ut1LocalTime :: Rational -> Iso' UniversalTime LocalTime ut1LocalTime long = iso localise globalise where NominalDiffTime posixDay@(Micro usDay) = posixDayLength @@ -152,8 +157,11 @@ , zonedTimeZone :: !TimeZone } deriving (Eq, Ord, Data, Typeable) +instance NFData ZonedTime where + rnf ZonedTime {..} = rnf zonedTimeZone + {-# INLINE zonedTime #-} -zonedTime :: Simple Iso (TimeZone, UTCTime) ZonedTime +zonedTime :: Iso' (TimeZone, UTCTime) ZonedTime zonedTime = iso toZoned fromZoned where {-# INLINE toZoned #-} diff --git a/src/Data/Thyme/Time.hs b/src/Data/Thyme/Time.hs --- a/src/Data/Thyme/Time.hs +++ b/src/Data/Thyme/Time.hs @@ -1,30 +1,56 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ViewPatterns #-} --- | Compatibility between thyme and time. -module Data.Thyme.Time where +-- | This module provides compatibility wrappers for the things that @thyme@ +-- does differently from @time@, and allows it to be used as a drop-in +-- replacement for the latter, with the exceptions noted below: +-- +-- * When constructing an 'UTCTime' or 'UniversalTime', use 'mkUTCTime' or +-- 'mkModJulianDate' in place of @UTCTime@ or @ModJulianDate@. +-- +-- * Instead of pattern matching on @UTCTime@, use 'unUTCTime' to get +-- a 'UTCView', which has a constructor @UTCTime@ with the same fields. +-- For @ModJulianDate@, use 'getModJulianDate'. @ViewPatterns@ may make +-- the transition more seamless. +-- +-- * Where a third party library uses @time@, you can use 'toThyme' and +-- 'fromThyme' to convert between the corresponding types. +-- +-- * 'Year's are 'Int's, not 'Integer's: you may need 'fromIntegral'. +-- +-- You shouldn't need to use @lens@ or @vector-space@ if you don't want to. +-- +-- Anything else is probably not intentional, and you should either contact +-- me via IRC or file an issue at . +module Data.Thyme.Time + ( module Data.Thyme + , module Data.Thyme.Time + ) where + import Control.Lens import Data.AffineSpace -import Data.Basis import Data.Int import Data.Micro -import Data.Thyme.Calendar +import Data.Ratio +import Data.Thyme import Data.Thyme.Calendar.OrdinalDate import Data.Thyme.Calendar.MonthDay import Data.Thyme.Calendar.WeekDate import Data.Thyme.Clock.Internal import Data.Thyme.Clock.POSIX import Data.Thyme.Clock.TAI -import Data.Thyme.LocalTime import qualified Data.Time.Calendar as T import qualified Data.Time.Clock as T import qualified Data.Time.Clock.TAI as T import qualified Data.Time.LocalTime as T -class Thyme a b where - thyme :: Simple Iso a b +-- * Type conversion +class Thyme a b | b -> a where + thyme :: Iso' a b + instance Thyme T.Day Day where {-# INLINE thyme #-} thyme = iso @@ -37,9 +63,8 @@ instance Thyme T.DiffTime DiffTime where {-# INLINE thyme #-} - thyme = iso (microsecondsToDiffTime . round . (*) 1000000) - ( \ (DiffTime (Micro t)) -> - T.picosecondsToDiffTime $ toInteger t * 1000000 ) + thyme = iso (round . (*) 1000000) + (T.picosecondsToDiffTime . (*) 1000000 . toInteger) . microDiffTime instance Thyme T.UTCTime UTCView where {-# INLINE thyme #-} @@ -53,8 +78,8 @@ instance Thyme T.NominalDiffTime NominalDiffTime where {-# INLINE thyme #-} - thyme = iso (microsecondsToNominalDiffTime . round . (*) 1000000) - (\ (NominalDiffTime t) -> fromRational $ t ^/^ basisValue ()) + thyme = iso (round . (*) 1000000) -- no picosecondsToNominalDiffTime D: + (fromRational . (% 1000000) . toInteger) . microNominalDiffTime instance Thyme T.AbsoluteTime AbsoluteTime where {-# INLINE thyme #-} @@ -69,9 +94,9 @@ instance Thyme T.TimeOfDay TimeOfDay where {-# INLINE thyme #-} thyme = iso ( \ (T.TimeOfDay h m s) -> TimeOfDay h m - . microsecondsToDiffTime . round $ s * 1000000 ) - ( \ (TimeOfDay h m s) -> T.TimeOfDay h m - . fromRational $ s ^/^ basisValue () ) + . view microDiffTime . round $ s * 1000000 ) + ( \ (TimeOfDay h m s) -> T.TimeOfDay h m . fromRational + . (% 1000000) . toInteger $ review microDiffTime s ) instance Thyme T.LocalTime LocalTime where {-# INLINE thyme #-} @@ -85,8 +110,16 @@ (\ (T.ZonedTime t z) -> ZonedTime (view thyme t) (view thyme z)) (\ (ZonedTime t z) -> T.ZonedTime (review thyme t) (review thyme z)) +{-# INLINE toThyme #-} +toThyme :: (Thyme a b) => a -> b +toThyme = view thyme + +{-# INLINE fromThyme #-} +fromThyme :: (Thyme a b) => b -> a +fromThyme = review thyme + ------------------------------------------------------------------------ --- * "Data.Time.Calendar" +-- * @Data.Time.Calendar@ {-# INLINE addDays #-} addDays :: Days -> Day -> Day @@ -129,7 +162,7 @@ . gregorianYearsRollover n . view gregorian ------------------------------------------------------------------------ --- * "Data.Time.Calendar.MonthDay" +-- * @Data.Time.Calendar.MonthDay@ {-# INLINE dayOfYearToMonthAndDay #-} dayOfYearToMonthAndDay :: Bool -> DayOfYear -> (Month, DayOfMonth) @@ -144,7 +177,7 @@ monthAndDayToDayOfYearValid leap m d = monthDayValid leap (MonthDay m d) ------------------------------------------------------------------------ --- * "Data.Time.Calendar.OrdinalDate" +-- * @Data.Time.Calendar.OrdinalDate@ {-# INLINE toOrdinalDate #-} toOrdinalDate :: Day -> (Year, DayOfYear) @@ -183,7 +216,7 @@ fromMondayStartWeekValid y w d = mondayWeekValid (MondayWeek y w d) ------------------------------------------------------------------------ --- * "Data.Time.Calendar.WeekDate" +-- * @Data.Time.Calendar.WeekDate@ {-# INLINE toWeekDate #-} toWeekDate :: Day -> (Year, WeekOfYear, DayOfWeek) @@ -198,8 +231,17 @@ fromWeekDateValid y w d = weekDateValid (WeekDate y w d) ------------------------------------------------------------------------ --- * "Data.Time.Clock" +-- * @Data.Time.Clock@ +{-# INLINE getModJulianDate #-} +getModJulianDate :: UniversalTime -> Rational +getModJulianDate = view modJulianDate + +-- | Replacement for 'T.ModJulianDate'. +{-# INLINE mkModJulianDate #-} +mkModJulianDate :: Rational -> UniversalTime +mkModJulianDate = review modJulianDate + {-# INLINE secondsToDiffTime #-} secondsToDiffTime :: Int64 -> DiffTime secondsToDiffTime a = DiffTime (Micro $ a * 1000000) @@ -208,6 +250,14 @@ picosecondsToDiffTime :: Int64 -> DiffTime picosecondsToDiffTime a = DiffTime (Micro $ div (a + 500000) 1000000) +{-# INLINE mkUTCTime #-} +mkUTCTime :: Day -> DiffTime -> UTCTime +mkUTCTime d t = review utcTime (UTCTime d t) + +{-# INLINE unUTCTime #-} +unUTCTime :: UTCTime -> UTCView +unUTCTime = view utcTime + {-# INLINE addUTCTime #-} addUTCTime :: NominalDiffTime -> UTCTime -> UTCTime addUTCTime = flip (.+^) @@ -217,7 +267,7 @@ diffUTCTime = (.-.) ------------------------------------------------------------------------ --- * "Data.Time.Clock.POSIX" +-- * @Data.Time.Clock.POSIX@ {-# INLINE posixSecondsToUTCTime #-} posixSecondsToUTCTime :: POSIXTime -> UTCTime @@ -228,7 +278,7 @@ utcTimeToPOSIXSeconds = view posixTime ------------------------------------------------------------------------ --- * "Data.Time.Clock.TAI" +-- * @Data.Time.Clock.TAI@ {-# INLINE addAbsoluteTime #-} addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime @@ -247,7 +297,7 @@ taiToUTCTime = review . absoluteTime ------------------------------------------------------------------------ --- * "Data.Time.LocalTime" +-- * @Data.Time.LocalTime@ {-# INLINE utcToLocalTimeOfDay #-} utcToLocalTimeOfDay :: TimeZone -> TimeOfDay -> (Days, TimeOfDay) diff --git a/tests/sanity.hs b/tests/sanity.hs --- a/tests/sanity.hs +++ b/tests/sanity.hs @@ -19,6 +19,7 @@ import Data.ByteString (ByteString) import Data.Monoid import Data.Thyme +import Data.Thyme.Time import qualified Data.Time as T import Data.VectorSpace import System.Exit @@ -36,7 +37,8 @@ # endif import qualified Data.ByteString.Lazy as L #else -import qualified Data.ByteString.UTF8 as U8 +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text #endif {-# INLINE utf8String #-} @@ -44,7 +46,7 @@ #if MIN_VERSION_bytestring(0,10,0) utf8String = L.toStrict . B.toLazyByteString . B.stringUtf8 #else -utf8String = U8.fromString +utf8String = Text.encodeUtf8 . Text.pack #endif ------------------------------------------------------------------------ @@ -60,13 +62,6 @@ instance Arbitrary UTCTime where arbitrary = fmap (review utcTime) $ UTCTime <$> arbitrary <*> arbitrary -toTime :: UTCTime -> T.UTCTime -toTime (view utcTime -> UTCTime (ModifiedJulianDay d) t) = T.UTCTime - (T.ModifiedJulianDay $ fromIntegral d) (fromRational $ t ^/^ basisValue ()) - -(^/^) :: (HasBasis v, Basis v ~ (), Scalar v ~ s, Fractional s) => v -> v -> s -x ^/^ y = decompose' x () / decompose' y () - ------------------------------------------------------------------------ newtype Spec = Spec String deriving (Show) @@ -111,16 +106,17 @@ ------------------------------------------------------------------------ prop_formatTime :: Spec -> UTCTime -> Property -prop_formatTime (Spec spec) t@(toTime -> t') +prop_formatTime (Spec spec) t@(review thyme -> t') = printTestCase desc (s == s') where s = formatTime defaultTimeLocale spec t s' = T.formatTime defaultTimeLocale spec t' desc = "thyme: " ++ s ++ "\ntime: " ++ s' prop_parseTime :: Spec -> UTCTime -> Property -prop_parseTime (Spec spec) (T.formatTime defaultTimeLocale spec . toTime -> s) - = printTestCase desc (fmap toTime t == t') where - t = parseTime defaultTimeLocale spec s +prop_parseTime (Spec spec) orig + = printTestCase desc (fmap (review thyme) t == t') where + s = T.formatTime defaultTimeLocale spec (review thyme orig) + t = parseTime defaultTimeLocale spec s :: Maybe UTCTime t' = T.parseTime defaultTimeLocale spec s tp = P.parseOnly (timeParser defaultTimeLocale spec) . utf8String desc = "input: " ++ show s ++ "\nthyme: " ++ show t @@ -136,7 +132,7 @@ [] ts <- Gen.unGen (vectorOf 10 arbitrary) <$> newStdGen <*> pure 0 - let ts' = toTime <$> ts + let ts' = review thyme <$> (ts :: [UTCTime]) let ss = T.formatTime defaultTimeLocale spec <$> ts' fast <- fmap and . withConfig config $ do env <- measureEnvironment diff --git a/thyme.cabal b/thyme.cabal --- a/thyme.cabal +++ b/thyme.cabal @@ -1,8 +1,11 @@ name: thyme -version: 0.2.1.0 +version: 0.2.2.0 synopsis: A faster time library description: - A faster time library + Thyme is a rewrite of the fine @time@ library, with a particular focus + on performance for applications that make heavy use of timestamps. + . + See "Data.Thyme" for a full description. homepage: https://github.com/liyang/thyme license: BSD3 license-file: LICENSE @@ -38,10 +41,6 @@ default: False manual: True -flag utf8-string - description: use utf8-string with bytestring < 0.10 - default: False - library hs-source-dirs: src exposed-modules: @@ -68,18 +67,16 @@ build-depends: attoparsec >= 0.10, base >= 4.5 && < 5, + bytestring >= 0.9, containers, deepseq >= 1.2, lens >= 3.8, old-locale >= 1.0, + text >= 0.11, template-haskell >= 2.6, time >= 1.4, transformers, vector-space >= 0.8 - if flag(utf8-string) - build-depends: bytestring >= 0.9, utf8-string >= 0.3 - else - build-depends: bytestring >= 0.10 ghc-options: -Wall if flag(bug-for-bug) cpp-options: -DBUG_FOR_BUG=1 @@ -103,12 +100,11 @@ lens, old-locale, random, + text, thyme, time, transformers, vector-space - if flag(utf8-string) - build-depends: utf8-string ghc-options: -Wall -- vim: et sw=4 ts=4 sts=4: