Add a faster implementation of TimeZoneSeries

extra-time.cabal

@@ -12,13 +12,14 @@ library
   hs-source-dirs:     src
   default-language:   Haskell2010
   default-extensions:
+    BangPatterns
     DataKinds
     DeriveFunctor
     DeriveGeneric
     DerivingStrategies
     GeneralizedNewtypeDeriving
-    ImportQualifiedPost
     KindSignatures
+    NamedFieldPuns
     OverloadedStrings
     RankNTypes
     ScopedTypeVariables
@@ -36,7 +37,6 @@ library
     file-embed ,
     deepseq ,
     mtl >= 2.2 ,
-    template-haskell ,
     text ,
     th-lift ,
     time,
@@ -55,6 +55,7 @@ library
       xml-conduit-writer ,
   exposed-modules:
     Data.Time.Extra
+    Data.Time.FastSeries
     Data.Time.Fmt
     Data.Time.Holidays
     Data.Time.LocalTime.Short

src/Data/Time/Extra.hs

@@ -4,6 +4,7 @@ module Data.Time.Extra
   , _Minutes
   , duration
   , durationLocal
+  , durationUTC
   , minutesToNDF
   , UTCDate(..)
   , _UTCDate
@@ -84,6 +85,12 @@ durationLocal t1 t2 = Minutes (timeDiff `div` 60)
     calcDiff = diffUTCTime `on` localTimeToUTC utc
     timeDiff = round (calcDiff t1 t2)
 
+durationUTC :: UTCTime -> UTCTime -> Minutes
+durationUTC t1 t2 = Minutes (timeDiff `div` 60)
+  where
+    calcDiff = diffUTCTime
+    timeDiff = round (calcDiff t1 t2)
+
 minutesToNDF :: Minutes -> NominalDiffTime
 minutesToNDF (Minutes mins) = 60 * realToFrac mins
 

src/Data/Time/FastSeries.hs

@@ -0,0 +1,85 @@
+module Data.Time.FastSeries
+  ( TimeZoneSeries
+  , toTimeZoneSeries
+  , fromTimeZoneSeries
+  , timeZoneFromSeries
+  , timeZoneFromSeriesLocal
+  , utcToLocalTime'
+  , localTimeToUTC'
+  ) where
+
+import Data.Map.Strict (Map)
+import qualified Data.Map as Map
+import Data.Time
+import qualified Data.Time.LocalTime.TimeZone.Series as Series
+
+
+-- | Contains the same data as 'Series.TimeZoneSeries' but precomputes some data
+-- for faster conversion.
+data TimeZoneSeries = TimeZoneSeries
+  { fallback :: !TimeZone
+  , transitionsUTC :: !(Map UTCTime TimeZone)
+    -- ^ UTC -> Local wants to know the last transition that happened before a
+    -- given 'UTCTime'
+  , transitionsLocal :: !(Map LocalTime TimeZone)
+    -- ^ Local -> UTC wants to know the largest transition @t@ into timezone
+    -- @tz@ such that @t <= localTimeToUTC tz lt@ where @lt@ is a given
+    -- 'LocalTime'. For a given TZ and valid time arguments, 'localTimeToUTC'
+    -- and 'utcToLocalTime' are inverses. Hence this is equivalent to
+    -- @utcToLocalTime t tz <= lt@.
+  }
+
+toTimeZoneSeries :: Series.TimeZoneSeries -> TimeZoneSeries
+toTimeZoneSeries
+  Series.TimeZoneSeries { Series.tzsTimeZone, Series.tzsTransitions }
+  = TimeZoneSeries
+    { fallback = tzsTimeZone
+    , transitionsUTC = Map.fromDescList tzsTransitions
+    , transitionsLocal = Map.fromList
+      [(utcToLocalTime tz u, tz) | (u, tz) <- tzsTransitions]
+    }
+
+fromTimeZoneSeries :: TimeZoneSeries -> Series.TimeZoneSeries
+fromTimeZoneSeries TimeZoneSeries { fallback, transitionsUTC }
+  = Series.TimeZoneSeries
+    { Series.tzsTimeZone = fallback
+    , Series.tzsTransitions = Map.toList transitionsUTC
+    }
+
+timeZoneFromSeries :: TimeZoneSeries -> UTCTime -> TimeZone
+timeZoneFromSeries TimeZoneSeries { fallback, transitionsUTC } t
+  = maybe fallback snd $ Map.lookupLE t transitionsUTC
+
+-- | See caveat on 'localTimeToUTC''.
+timeZoneFromSeriesLocal :: TimeZoneSeries -> LocalTime -> TimeZone
+timeZoneFromSeriesLocal TimeZoneSeries { fallback, transitionsLocal } lt
+  = maybe fallback snd $ Map.lookupLE lt transitionsLocal
+
+utcToLocalTime' :: TimeZoneSeries -> UTCTime -> LocalTime
+utcToLocalTime' tzsf t = utcToLocalTime tz t
+  where !tz = timeZoneFromSeries tzsf t
+
+-- | This conversion is not actually always well defined.
+--
+-- At the moment of switching to summer time, there is a range of 'LocalTime's
+-- that are skipped. For these, 'Series.isValidLocalTime' returns 'False'. This
+-- function converts them to 'UTCTime' as if the switch didn't happen.
+--
+-- Around the moment of switching away from summer time, there is a range of
+-- 'LocalTime's that happen twice: first before the switch, then once again
+-- after the switch. For these, 'Series.isRedundantLocalTime' returns 'True'.
+-- In such ambiguous cases, this function always picks the occurrence after the
+-- switch.
+--
+-- The handling of these corner cases matches exactly to that of
+-- 'Series.localTimeToUTC''
+--
+-- This means the equation
+-- @lt == utcToLocalTime' tzsf (localTimeToUTC' tzsf lt)@ does not hold for @lt@
+-- that were skipped. And the equation
+-- @t == localTimeToUTC' tzsf (utcToLocalTime' tzsf t)@ does not hold for @t@
+-- that come just before switching awya from summer time. For other arguments
+-- these equations are assumed to hold.
+localTimeToUTC' :: TimeZoneSeries -> LocalTime -> UTCTime
+localTimeToUTC' tzsf lt = localTimeToUTC tz lt
+  where !tz = timeZoneFromSeriesLocal tzsf lt

src/Data/Time/Holidays.hs

@@ -7,7 +7,7 @@ import           Data.Proxy
 import qualified Data.Set as S
 import           Data.Time
 import           Data.Time.Calendar.OrdinalDate
-import           Data.Time.LocalTime.TimeZone.Series
+import           Data.Time.FastSeries
 import           Data.FileEmbed (makeRelativeToProject)
 import           Data.Csv.Embed (embedRecords)
 import           Holidays.EDay (eDayToDay, EDay)

src/Data/Time/Utils.hs

@@ -13,7 +13,7 @@ module Data.Time.Utils
 
 import           Control.Lens
 import           Data.Time
-import           Data.Time.LocalTime.TimeZone.Series
+import           Data.Time.FastSeries
 
 
 the24h :: NominalDiffTime
@@ -25,15 +25,15 @@ oneHour = 60 * 60
 oneMinute :: NominalDiffTime
 oneMinute = 60
 
--- | Calculate TimeZone using TimeZoneSeries and construct ZonedTime
+-- | Calculate 'TimeZone' using 'TimeZoneSeries' and construct 'ZonedTime'.
+--
+-- See caveats on 'localTimeToUTC''.
 zoneLocalTime
   :: TimeZoneSeries
   -> LocalTime
   -> ZonedTime
-zoneLocalTime tzs lt = let
-  u  = localTimeToUTC' tzs lt
-  tz = timeZoneFromSeries tzs u
-  in ZonedTime lt tz
+zoneLocalTime tzsf lt = ZonedTime lt tz
+  where !tz = timeZoneFromSeriesLocal tzsf lt
 
 makeLensesFor
   [("zonedTimeToLocalTime", "_zonedTimeToLocalTime")] ''ZonedTime

src/Holidays/EDay.hs

@@ -7,7 +7,7 @@ import Data.ByteString.Char8
 import Data.Csv
 import Data.Time
 import Data.Time.Calendar.OrdinalDate
-import Data.Vector qualified as V
+import qualified Data.Vector as V
 import Language.Haskell.TH.Lift
 
 data EDay = EDay {edYear :: Integer, edDay :: Int}