Add POSIX-TZ support

Data/Time/Zones.hs

@@ -31,6 +31,7 @@ module Data.Time.Zones (
   loadLocalTZ,
   -- * Utilities
   diffForAbbr,
+  renderPosixTz,
   ) where
 
 import           Control.DeepSeq
@@ -39,30 +40,72 @@ import           Data.Data
 import           Data.Int (Int64)
 import           Data.Time
 import           Data.Time.Zones.Internal
+import           Data.Time.Zones.Internal.PosixTz (renderPosixTz)
 import           Data.Time.Zones.Read
 import           Data.Time.Zones.Types
 import qualified Data.Vector as VB
 import qualified Data.Vector.Unboxed as VU
+import qualified Data.ByteString.Char8 as B8
 
 -- | Returns the time difference (in seconds) for TZ at the given
 -- POSIX time.
 diffForPOSIX :: TZ -> Int64 -> Int
 {-# INLINE diffForPOSIX #-}
-diffForPOSIX (TZ trans diffs _) t = VU.unsafeIndex diffs $ binarySearch trans t
+diffForPOSIX (TZ trans diffs _ mptz) t =
+  if t < VU.last trans
+  then useExplicit
+  else maybe useExplicit (`diffForPOSIXFromRule` t) mptz
+  where
+    useExplicit = VU.unsafeIndex diffs $ binarySearch trans t
+
+-- | Returns a time difference (in seconds) for `PosixTz` at given
+-- POSIX time.
+diffForPOSIXFromRule :: PosixTz -> Int64 -> Int
+{-# INLINE diffForPOSIXFromRule #-}
+diffForPOSIXFromRule ptz t =
+  diffMins * 60
+  where
+    TimeZone diffMins _ _ = timeZoneFromRule ptz t
 
+-- | Returns the `TimeZone` for given index of `TZ` data.
+--
+-- /Note/: This ignores POSIX-TZ rules.
 timeZoneForIx :: TZ -> Int -> TimeZone
 {-# INLINE timeZoneForIx #-}
-timeZoneForIx (TZ _ diffs infos) i = TimeZone diffMins isDst name
+timeZoneForIx (TZ _ diffs infos _) i = TimeZone diffMins isDst name
   where
     diffMins = VU.unsafeIndex diffs i `div` 60
     (isDst, name) = VB.unsafeIndex infos i
 
+-- | Returns the `TimeZone` for the `PosixTz` at given POSIX time.
+timeZoneFromRule :: PosixTz -> Int64 -> TimeZone
+{-# INLINE timeZoneFromRule #-}
+timeZoneFromRule (PosixTz (PosixZone std stdoff) mdst) t = maybe stdtz f mdst
+  where
+    toDiffMins x = fromIntegral (-x) `div` 60
+    stdtz = TimeZone (toDiffMins stdoff) False (mkname std)
+    -- 'TimeZone' does not use the angle bracket notation
+    mkname = B8.unpack . B8.dropWhile (== '<') . B8.dropWhileEnd (== '>')
+
+    f (PosixZone dst dstoff, rbeg, rend) =
+      let (y, _, _) = toGregorian . localDay $ int64PairToLocalTime t 0
+          beg = ruleToSecs rbeg (fromIntegral y) + fromIntegral stdoff
+          end = ruleToSecs rend (fromIntegral y) + fromIntegral dstoff
+          isdst = if beg > end
+                  then t < end || t >= beg
+                  else t >= beg && t < end
+          dsttz = TimeZone (toDiffMins dstoff) True (mkname dst)
+      in if isdst then dsttz else stdtz
+
 -- | Returns the `TimeZone` for the `TZ` at the given POSIX time.
 timeZoneForPOSIX :: TZ -> Int64 -> TimeZone
 {-# INLINABLE timeZoneForPOSIX #-}
-timeZoneForPOSIX tz@(TZ trans _ _) t = timeZoneForIx tz i
+timeZoneForPOSIX tz@(TZ trans _ _ mptz) t =
+  if t < VU.last trans
+  then useExplicit
+  else maybe useExplicit (`timeZoneFromRule` t) mptz
   where
-    i = binarySearch trans t
+    useExplicit = timeZoneForIx tz (binarySearch trans t)
 
 -- | Returns the `TimeZone` for the `TZ` at the given `UTCTime`.
 timeZoneForUTCTime :: TZ -> UTCTime -> TimeZone
@@ -151,7 +194,7 @@ instance NFData FromLocal where
 -- TODO(klao): check that these assuptions hold.
 localToPOSIX :: TZ -> Int64 -> FromLocal
 {-# INLINABLE localToPOSIX #-}
-localToPOSIX (TZ trans diffs _) !lTime = res
+localToPOSIX (TZ trans diffs _ _) !lTime = res
   where
     lBound = lTime - 86400
     ix = binarySearch trans lBound
@@ -202,7 +245,7 @@ instance NFData LocalToUTCResult where
 
 -- TODO(klao): better name
 localTimeToUTCFull :: TZ -> LocalTime -> LocalToUTCResult
-localTimeToUTCFull tz@(TZ _ diffs _) localT = res
+localTimeToUTCFull tz@(TZ _ diffs _ _) localT = res
   where
     (t,ps) = localTimeToInt64Pair localT
     addDiff i = int64PairToUTCTime t' ps
@@ -239,7 +282,7 @@ localTimeToUTCTZ tz lt =
 -- on the abbreviation.)
 diffForAbbr :: TZ -> String -> Maybe Int
 {-# INLINABLE diffForAbbr #-}
-diffForAbbr (TZ _ diffs infos) s =
+diffForAbbr (TZ _ diffs infos _) s =
   case VB.findIndex ((==) s . snd) $ VB.reverse infos of
     Nothing -> Nothing
     Just i -> Just $ VU.unsafeIndex diffs (VU.length diffs - 1 - i)

Data/Time/Zones/Internal.hs

@@ -18,24 +18,37 @@ module Data.Time.Zones.Internal (
   localTimeToInt64Pair,
   int64PairToUTCTime,
   int64PairToLocalTime,
+  -- * POSIX-TZ helper functions
+  ruleToSecs,
+  yearToSecs,
+  daysInMonth,
+  monthToSecs,
   -- * Low-level \"coercions\"
   picoToInteger,
   integerToPico,
   diffTimeToPico,
   picoToDiffTime,
   diffTimeToInteger,
   integerToDiffTime,
+  -- * Backwards combatibility
+  getEnvMaybe,
   ) where
 
+import Data.Bits ( Bits((.&.), shiftR) )
 import Data.Fixed
 import Data.Int
 import Data.Time
+import qualified Data.Vector.Unboxed as VU
+import System.Environment ( getEnv )
+import System.IO.Error ( catchIOError, isDoesNotExistError )
 #ifdef TZ_TH
 import Data.Time.Zones.Internal.CoerceTH
 #else
 import Unsafe.Coerce
 #endif
 
+import Data.Time.Zones.Types
+
 utcTimeToInt64Pair :: UTCTime -> (Int64, Int64)
 utcTimeToInt64Pair (UTCTime (ModifiedJulianDay d) t)
   = (86400 * (fromIntegral d - unixEpochDay) + s, ps)
@@ -79,6 +92,60 @@ utcTimeToInt64 (UTCTime (ModifiedJulianDay d) t)
     unixEpochDay = 40587
 {-# INLINE utcTimeToInt64 #-}
 
+--------------------------------------------------------------------------------
+-- POSIX-TZ helper functions
+
+-- | Convert 'TzRule' plus year to number of seconds since epoch
+--
+-- See musl rule_to_secs()
+ruleToSecs :: TzRule -> Int64 -> Int64
+ruleToSecs (TzRule ty m n d t) y =
+  ys + ms + fromIntegral t
+  where
+    secsperday = 86400
+    isleap = isLeapYear (fromIntegral y)
+    ys = yearToSecs y
+    ms = case ty of
+      TzRuleJ -> fromIntegral (if not isleap || d < 60 then d - 1 else d) * secsperday
+      TzRuleN -> fromIntegral d * secsperday
+      TzRuleM ->
+        let
+          -- s1 = seconds until start of the month
+          s1 = fromIntegral $ monthToSecs isleap (m - 1)
+          t0 = ys + s1
+          wday = ((t0 + 4*secsperday) `mod` (7*secsperday)) `div` secsperday
+          d1 = fromIntegral d - wday
+          d2 = if d1 < 0 then d1 + 7 else d1
+          n1 = fromIntegral $ if n == 5 && d2+28 >= fromIntegral (daysInMonth isleap m)
+                              then 4
+                              else n
+          s2 = secsperday * (d2 + 7*(n1-1))
+        in s1 + s2
+{-# INLINE ruleToSecs #-}
+
+-- | Number of seconds since epoch for year
+yearToSecs :: Int64 -> Int64
+yearToSecs y64 =
+  utcTimeToInt64 $ UTCTime (fromGregorian (fromIntegral y64) 1 1) 0
+{-# INLINE yearToSecs #-}
+
+-- | Number of days in month
+daysInMonth :: Bool -> Int -> Int
+daysInMonth isleap 2 = 28 + if isleap then 1 else 0
+daysInMonth _      m = 30 + ((0xad5 `shiftR` (m - 1)) .&. 1)
+{-# INLINE daysInMonth #-}
+
+-- | Number of seconds between start of year and end of month (1-12)
+monthToSecs :: Bool -> Int -> Int
+monthToSecs isleap m =
+  d * 86400
+  where
+    d = VU.unsafeIndex sumdays m + if isleap && m >= 2 then 1 else 0
+
+    sumdays :: VU.Vector Int
+    sumdays = VU.fromList [ 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 ]
+{-# INLINE monthToSecs #-}
+
 --------------------------------------------------------------------------------
 -- Low-level zero-overhead conversions.
 -- Basically we could have used 'coerce' if the constructors were exported.
@@ -138,3 +205,13 @@ integerToDiffTime = unsafeCoerce
 {-# INLINE integerToDiffTime #-}
 
 #endif
+
+--------------------------------------------------------------------------------
+-- Backwards compatibility
+
+-- | This is equivalent to 'lookupEnv', defined for compatibility with
+-- base < 4.6.0.0
+getEnvMaybe :: String -> IO (Maybe String)
+getEnvMaybe var =
+  fmap Just (getEnv var) `catchIOError`
+  (\e -> if isDoesNotExistError e then return Nothing else ioError e)