tz 0.0.0.6 → 0.0.0.7
raw patch · 6 files changed
+295/−48 lines, 6 filesdep ~time
Dependency ranges changed: time
Files
- Data/Time/Zones.hs +9/−22
- Data/Time/Zones/Internal.hs +103/−0
- Data/Time/Zones/Internal/CoerceTH.hs +37/−0
- benchmarks/benchConv.hs +76/−0
- benchmarks/benchGreg.hs +54/−24
- tz.cabal +16/−2
Data/Time/Zones.hs view
@@ -31,13 +31,13 @@ ) where import Data.Bits (shiftR)-import Data.Fixed (divMod') import Data.Int (Int64) import Data.Time import qualified Data.Vector as VB import qualified Data.Vector.Unboxed as VU import Data.Time.Zones.Types import Data.Time.Zones.Read+import Data.Time.Zones.Internal -- | Returns the time difference (in seconds) for TZ at the given -- POSIX time.@@ -62,8 +62,7 @@ -- | Returns the `TimeZone` for the `TZ` at the given `UTCTime`. timeZoneForUTCTime :: TZ -> UTCTime -> TimeZone {-# INLINABLE timeZoneForUTCTime #-}-timeZoneForUTCTime tz (UTCTime day tid)- = timeZoneForPOSIX tz $ dayTimeToInt64 day tid+timeZoneForUTCTime tz ut = timeZoneForPOSIX tz $ utcTimeToInt64 ut -- | Returns the `LocalTime` corresponding to the given `UTCTime` in `TZ`. --@@ -71,14 +70,10 @@ -- (`timeZoneForPOSIX` tz ut) ut@ except when the time difference is not -- an integral number of minutes utcToLocalTimeTZ :: TZ -> UTCTime -> LocalTime-utcToLocalTimeTZ tz (UTCTime day dtime) = LocalTime day' tod+utcToLocalTimeTZ tz utcT = int64PairToLocalTime ut' ps where- diff = diffForPOSIX tz $ dayTimeToInt64 day dtime- (m', s) = (dtime + fromIntegral diff) `divMod'` 60- (h', m) = m' `divMod` 60- (d', h) = h' `divMod` 24- day' = fromIntegral d' `addDays` day- tod = TimeOfDay h m (realToFrac s)+ (ut, ps) = utcTimeToInt64Pair utcT+ ut' = ut + fromIntegral (diffForPOSIX tz ut) -- | The `TZ` definition for UTC. utcTZ :: TZ@@ -198,23 +193,15 @@ , _ltuSecondZone :: TimeZone } deriving (Eq, Show) --- TODO(klao): measure the improvement-dayTimeToInt64 :: RealFrac a => Day -> a -> Int64-{-# INLINE dayTimeToInt64 #-}-dayTimeToInt64 (ModifiedJulianDay d) t = 86400 * (fromIntegral d - unixEpochDay) + floor t- where- unixEpochDay = 40587- -- TODO(klao): better name localTimeToUTCFull :: TZ -> LocalTime -> LocalToUTCResult-localTimeToUTCFull tz@(TZ _ diffs _) (LocalTime day tod) = res+localTimeToUTCFull tz@(TZ _ diffs _) localT = res where- tid = timeOfDayToTime tod- t = dayTimeToInt64 day tid- addDiff i = UTCTime (addDays d day) tid'+ (t,ps) = localTimeToInt64Pair localT+ addDiff i = int64PairToUTCTime t' ps where diff = VU.unsafeIndex diffs i- (d, tid') = (tid - fromIntegral diff) `divMod'` 86400+ t' = t - fromIntegral diff res = case localToPOSIX tz t of FLGap i _ -> LTUNone (addDiff i) (timeZoneForIx tz i) FLUnique i _ -> LTUUnique (addDiff i) (timeZoneForIx tz i)
+ Data/Time/Zones/Internal.hs view
@@ -0,0 +1,103 @@+{- |+Module : Data.Time.Zones.Internal+Copyright : (C) 2014 Mihaly Barasz+License : Apache-2.0, see LICENSE+Maintainer : Mihaly Barasz <klao@nilcons.com>+Stability : experimental+-}++{-# LANGUAGE TemplateHaskell #-}++module Data.Time.Zones.Internal (+ -- * Time conversion to/from @Int64@+ utcTimeToInt64,+ utcTimeToInt64Pair,+ localTimeToInt64Pair,+ int64PairToUTCTime,+ int64PairToLocalTime,+ -- * Low-level \"coercions\"+ picoToInteger,+ integerToPico,+ diffTimeToPico,+ picoToDiffTime,+ diffTimeToInteger,+ integerToDiffTime,+ ) where++import Data.Fixed+import Data.Int+import Data.Time+import Data.Time.Zones.Internal.CoerceTH++utcTimeToInt64Pair :: UTCTime -> (Int64, Int64)+utcTimeToInt64Pair (UTCTime (ModifiedJulianDay d) t)+ = (86400 * (fromIntegral d - unixEpochDay) + s, ps)+ where+ (s, ps) = fromIntegral (diffTimeToInteger t) `divMod` 1000000000000+ unixEpochDay = 40587+{-# INLINE utcTimeToInt64Pair #-}++int64PairToLocalTime :: Int64 -> Int64 -> LocalTime+int64PairToLocalTime t ps = LocalTime (ModifiedJulianDay day) (TimeOfDay h m s)+ where+ (day64, tid64) = t `divMod` 86400+ day = fromIntegral $ day64 + 40587+ (h, ms) = fromIntegral tid64 `quotRem` 3600+ (m, s0) = ms `quotRem` 60+ s = integerToPico $ fromIntegral $ ps + 1000000000000 * fromIntegral s0+{-# INLINE int64PairToLocalTime #-}++localTimeToInt64Pair :: LocalTime -> (Int64, Int64)+localTimeToInt64Pair (LocalTime (ModifiedJulianDay day) (TimeOfDay h m s))+ = (86400 * (fromIntegral day - unixEpochDay) + tid, ps)+ where+ (s64, ps) = fromIntegral (picoToInteger s) `divMod` 1000000000000+ tid = s64 + fromIntegral (h * 3600 + m * 60)+ unixEpochDay = 40587+{-# INLINE localTimeToInt64Pair #-}++int64PairToUTCTime :: Int64 -> Int64 -> UTCTime+int64PairToUTCTime t ps = UTCTime (ModifiedJulianDay day) tid+ where+ (day64, tid64) = t `divMod` 86400+ day = fromIntegral $ day64 + 40587+ tid = integerToDiffTime $ fromIntegral $ ps + tid64 * 1000000000000+{-# INLINE int64PairToUTCTime #-}++utcTimeToInt64 :: UTCTime -> Int64+utcTimeToInt64 (UTCTime (ModifiedJulianDay d) t)+ = 86400 * (fromIntegral d - unixEpochDay)+ + fromIntegral (diffTimeToInteger t) `div` 1000000000000+ where+ unixEpochDay = 40587+{-# INLINE utcTimeToInt64 #-}++--------------------------------------------------------------------------------+-- Low-level zero-overhead conversions.+-- Basically we could have used 'coerce' if the constructors were exported.++-- TODO(klao): Is it better to inline them saturated or unsaturated?++picoToInteger :: Pico -> Integer+picoToInteger p = $(destructNewType ''Fixed) p+{-# INLINE picoToInteger #-}++integerToPico :: Integer -> Pico+integerToPico i = $(constructNewType ''Fixed) i+{-# INLINE integerToPico #-}++diffTimeToPico :: DiffTime -> Pico+diffTimeToPico dt = $(destructNewType ''DiffTime) dt+{-# INLINE diffTimeToPico #-}++picoToDiffTime :: Pico -> DiffTime+picoToDiffTime p = $(constructNewType ''DiffTime) p+{-# INLINE picoToDiffTime #-}++diffTimeToInteger :: DiffTime -> Integer+diffTimeToInteger dt = picoToInteger (diffTimeToPico dt)+{-# INLINE diffTimeToInteger #-}++integerToDiffTime :: Integer -> DiffTime+integerToDiffTime i = picoToDiffTime (integerToPico i)+{-# INLINE integerToDiffTime #-}
+ Data/Time/Zones/Internal/CoerceTH.hs view
@@ -0,0 +1,37 @@+{- |+Module : Data.Time.Zones.Internal.CoerceTH+Copyright : (C) 2014 Mihaly Barasz+License : Apache-2.0, see LICENSE+Maintainer : Mihaly Barasz <klao@nilcons.com>+Stability : experimental+-}++{-# LANGUAGE TemplateHaskell #-}++module Data.Time.Zones.Internal.CoerceTH (+ getNewTypeCon,+ constructNewType,+ destructNewType,+ ) where++import Language.Haskell.TH++getNewTypeCon :: Name -> Q Name+getNewTypeCon newTy = do+ info <- reify newTy+ case info of+ TyConI (NewtypeD _ _ _ (NormalC name _) _) -> return name+ _ -> fail "Not a newtype"++constructNewType :: Name -> Q Exp+constructNewType newTy = ConE `fmap` getNewTypeCon newTy++destructNewType :: Name -> Q Exp+destructNewType newTy = do+ con <- getNewTypeCon newTy+ lamV <- newName "x"+ patV <- newName "v"+ return $+ LamE [VarP lamV]+ (CaseE (VarE lamV) [+ Match (ConP con [VarP patV]) (NormalB (VarE patV)) []])
+ benchmarks/benchConv.hs view
@@ -0,0 +1,76 @@+module Main (main) where++import Criterion.Main+import Data.Int+import Data.Time+import Data.Time.Clock.POSIX+import Data.Time.Zones.Internal++utc2int64Naive :: UTCTime -> Int64+utc2int64Naive ut = floor $ utcTimeToPOSIXSeconds ut++utc2int64Floor :: UTCTime -> Int64+utc2int64Floor (UTCTime (ModifiedJulianDay d) t)+ = 86400 * (fromIntegral d - unixEpochDay) + floor t+ where+ unixEpochDay = 40587++utc2int64Full :: UTCTime -> Int64+utc2int64Full (UTCTime (ModifiedJulianDay d) t)+ = 86400 * (fromIntegral d - unixEpochDay)+ + fromIntegral (diffTimeToInteger t) `div` 1000000000000+ where+ unixEpochDay = 40587+++local2utcNaive :: LocalTime -> UTCTime+local2utcNaive (LocalTime day tod) = UTCTime day (timeOfDayToTime tod)++local2utcNaive2 :: LocalTime -> UTCTime+local2utcNaive2 = localTimeToUTC utc++local2utcFull :: LocalTime -> UTCTime+local2utcFull (LocalTime day (TimeOfDay h m s)) = UTCTime day tid+ where+ ps :: Int64+ ps = fromIntegral (picoToInteger s)+ tid = integerToDiffTime (fromIntegral tid64)+ tid64 = ps + fromIntegral h * 3600000000000000 + fromIntegral m * 60000000000000+++utc2localNaive :: UTCTime -> LocalTime+utc2localNaive = utcToLocalTime utc++utc2localFull :: UTCTime -> LocalTime+utc2localFull (UTCTime day tid) = LocalTime day tod+ where+ tid64 :: Int64+ tid64 = fromIntegral (diffTimeToInteger tid)+ (hm, ps) = tid64 `divMod` 60000000000000+ (h, m) = fromIntegral hm `divMod` 60+ tod = TimeOfDay h m (integerToPico $ fromIntegral ps)+++benchmarks :: [Benchmark]+benchmarks = [+ bgroup "UTCTimeToInt64" [+ bench "naive" $ whnf utc2int64Naive t,+ bench "floor" $ whnf utc2int64Floor t,+ bench "full" $ whnf utc2int64Full t+ ],+ bgroup "LocalToUTC" [+ bench "naive" $ nf local2utcNaive l,+ bench "naive2" $ nf local2utcNaive2 l,+ bench "full" $ nf local2utcFull l+ ],+ bgroup "UTCToLocal" [+ bench "naive" $ nf utc2localNaive t,+ bench "full" $ nf utc2localFull t+ ]+ ]+ where+ t = UTCTime (fromGregorian 2014 07 23) 7268.123456789555+ l = LocalTime (fromGregorian 2014 07 23) (TimeOfDay 22 48 53.123456789888)++main :: IO ()+main = defaultMain benchmarks
benchmarks/benchGreg.hs view
@@ -14,7 +14,7 @@ data YD = YD { _ydYear :: {-# UNPACK #-} !Int, _ydDay :: {-# UNPACK #-} !Int- } deriving (Show)+ } deriving (Eq, Show) makeLenses ''YD @@ -58,6 +58,37 @@ year = quadcent * 400 + cent * 100 + quad * 4 + y + 1 --------------------------------------------------------------------------------+-- Brief description of the toOrdinal computation.+--+-- The length of the years in Gregorian calendar is periodic with+-- period of 400 years. There are 100 - 4 + 1 = 97 leap years in a+-- period, so the average length of a year is 365 + 97/400 =+-- 146097/400 days.+--+-- Now, if you consider these -- let's call them nominal -- years,+-- then for any point in time, for any linear day number we can+-- determine which nominal year does it fall into by a single+-- division. Moreover, if we align the start of the calendar year 1+-- with the start of the nominal year 1, then the calendar years and+-- nominal years never get too much out of sync. Specifically:+--+-- * start of the first day of a calendar year might fall into the+-- preceding nominal year, but never more than by 1.5 days (591/400+-- days, to be precise)+-- * the start of the last day of a calendar year always falls into+-- its nominal year (even for the leap years).+--+-- So, to find out the calendar year for a given day, we calculate+-- which nominal year does its start fall. And, if we are not too+-- close to the end of year, we have the right calendar+-- year. Othewise, we just check whether it falls within the next+-- calendar year.+--+-- Notes: to make the reasoning simpler and more efficient ('quot' is+-- faster than 'div') we do the computation directly only for positive+-- years (days after 1-1-1). For earlier dates we "transate" by an+-- integral number of 400 year periods, do the computation and+-- translate back. isLeapYearI :: Int -> Bool {-# INLINABLE isLeapYearI #-}@@ -71,33 +102,32 @@ where cs = ys `quot` 100 -toOrdinalB0 :: Int -> YD-{-# INLINE toOrdinalB0 #-}-toOrdinalB0 b0 = res- where- (y, r) = (400 * b0) `quotRem` 146097- ls = countLeapYears y- res = if r < 146097 - 400- then YD y (b0 - 365*y - ls)- else let y' = if isLeapYearI (y+1) then y else y+1- in YD y' (b0 - 365*y' - ls)--toOrdinalPr :: Int -> YD-{-# INLINABLE toOrdinalPr #-}-toOrdinalPr !mjd | b0 >= 0 = toOrdinalB0 b0- | otherwise = toOrdinalB0 m & ydYear +~ d * 400+toOrdinalImproved :: Int -> YD+{-# INLINABLE toOrdinalImproved #-}+toOrdinalImproved !mjd+ | b0 <= 0 = toOrdinalB0 m & ydYear +~ d * 400+ | otherwise = toOrdinalB0 b0 where b0 = mjd + 678575 (d,m) = b0 `divMod` 146097 -test :: Integer -> Int -> Int -> IO ()-test y m md = do- let d = fromIntegral $ toModifiedJulianDay $ fromGregorian y m md- print $ d + 678575- print $ toOrdinalDate' d- let YD y' yd = toOrdinalPr d- print $ YD (y'+1) (yd+1)+toOrdinalB0 :: Int -> YD+{-# INLINE toOrdinalB0 #-}+toOrdinalB0 dayB0 = res+ where+ (y0, r) = (400 * dayB0) `quotRem` 146097+ dayInYear y = dayB0 - 365 * y - countLeapYears y + 1+ d0 = dayInYear y0+ d1 = dayInYear (y0 + 1)+ res = if r >= 146097 - 591 && d1 > 0+ then YD (y0 + 2) d1+ else YD (y0 + 1) d0 +checkToOrdinalImproved :: [(Int, (YD, YD))]+checkToOrdinalImproved = filter (uncurry (/=) . snd) l+ where+ l = [ (d, (toOrdinalDate' d', toOrdinalImproved d'))+ | d <- [0 .. 400 * 366], let d' = d - 678575 ] benchmarks :: [Benchmark] benchmarks = [@@ -111,7 +141,7 @@ bgroup "optim" [ bench "directCopy" $ whnf toOrdinalDateI d1i, bench "divModQuotRem" $ whnf toOrdinalDateDivMod d1i,- bench "divModPr" $ whnf toOrdinalPr d1i+ bench "Improved" $ whnf toOrdinalImproved d1i ] ] where
tz.cabal view
@@ -1,5 +1,5 @@ Name: tz-Version: 0.0.0.6+Version: 0.0.0.7 License: Apache-2.0 License-File: LICENSE Author: Mihaly Barasz, Gergely Risko@@ -38,7 +38,9 @@ Data.Time.Zones.Types, Data.Time.Zones.Read, Data.Time.Zones.All,- Data.Time.Zones.TH+ Data.Time.Zones.TH,+ Data.Time.Zones.Internal,+ Data.Time.Zones.Internal.CoerceTH Other-Modules: Paths_tz Default-Language: Haskell2010 GHC-Options: -Wall@@ -142,4 +144,16 @@ criterion >= 0.8 && < 0.9, lens, thyme,+ time++Benchmark bench_conv+ Default-Language: Haskell2010+ Type: exitcode-stdio-1.0+ HS-Source-Dirs: benchmarks+ Main-Is: benchConv.hs+ GHC-Options: -Wall -O2+ Build-Depends:+ tz,+ base >= 4 && < 5,+ criterion >= 0.8 && < 0.9, time