module Data.Time.ZoneInfo (
Context,
ZoneInfo (..),
newContext,
newOlsonZone,
utcOlsonZone,
) where
import Data.Fixed
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time.LocalTime
import Foreign
import Foreign.C
data CContext
data CZoneInfo
type Context = ForeignPtr CContext
data OlsonZone = OlsonZone Context (Ptr CZoneInfo)
data CTm
foreign import ccall unsafe "olson_create"
c_create :: CString -> IO (Ptr CContext)
foreign import ccall unsafe "&olson_destroy"
c_destroy :: FunPtr (Ptr CContext -> IO ())
foreign import ccall unsafe "olson_get"
c_get :: Ptr CContext -> CString -> IO (Ptr CZoneInfo)
foreign import ccall unsafe "olson_gmt"
c_gmt :: Ptr CContext -> IO (Ptr CZoneInfo)
foreign import ccall unsafe "olson_localtime"
c_localtime :: Ptr CZoneInfo -> Ptr CTime -> Ptr CTm -> IO (Ptr CTm)
foreign import ccall unsafe "olson_mktime"
c_mktime :: Ptr CZoneInfo -> Ptr CTm -> IO CTime
foreign import ccall unsafe "olson_gmtoff"
c_gmtoff :: Ptr CZoneInfo -> CInt -> IO CLong
foreign import ccall unsafe "olson_zone"
c_zone :: Ptr CZoneInfo -> CInt -> IO (Ptr CChar)
toPico :: Real a => a -> Pico -> Pico
toPico i =
(+) (realToFrac i)
posixToUTCTime :: POSIXTime -> UTCTime
posixToUTCTime =
posixSecondsToUTCTime
utcToPOSIXTime :: UTCTime -> POSIXTime
utcToPOSIXTime =
utcTimeToPOSIXSeconds
cToPOSIXTime :: CTime -> Pico -> POSIXTime
cToPOSIXTime ct =
realToFrac . toPico ct
setCTmDay :: Ptr CTm -> Day -> IO ()
setCTmDay tm day = do
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) tm (fromIntegral year 1900 :: CInt)
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) tm (fromIntegral mon 1 :: CInt)
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) tm (fromIntegral mday :: CInt)
return ()
where
(year, mon, mday) = toGregorian day
getCTmDay :: Ptr CTm -> IO Day
getCTmDay tm = do
year <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) tm :: IO CInt
mon <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) tm :: IO CInt
mday <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) tm :: IO CInt
return $ fromGregorian (fromIntegral year + 1900)
(fromIntegral mon + 1) (fromIntegral mday)
setCTmTimeOfDay :: Ptr CTm -> TimeOfDay -> IO ()
setCTmTimeOfDay tm tod = do
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) tm (fromIntegral hour :: CInt)
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) tm (fromIntegral min' :: CInt)
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) tm (truncate sec :: CInt)
return ()
where
hour = todHour tod
min' = todMin tod
sec = todSec tod
getCTmTimeOfDay :: Ptr CTm -> Pico -> IO TimeOfDay
getCTmTimeOfDay tm psec = do
hour <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) tm :: IO CInt
min' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) tm :: IO CInt
sec <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) tm :: IO CInt
return $ TimeOfDay (fromIntegral hour) (fromIntegral min')
(toPico sec psec)
ctmToTimeZone :: Ptr CZoneInfo -> Ptr CTm -> IO TimeZone
ctmToTimeZone zi tm = do
isdst <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) tm :: IO CInt
gmtoff <- c_gmtoff zi isdst
zone <- c_zone zi isdst >>= peekCString
return $ TimeZone (fromIntegral $ div gmtoff 60) (isdst /= 0) zone
ctmToZonedTime :: Ptr CZoneInfo -> Ptr CTm -> Pico -> IO ZonedTime
ctmToZonedTime zi tm psec = do
day <- getCTmDay tm
tod <- getCTmTimeOfDay tm psec
zone <- ctmToTimeZone zi tm
return $ ZonedTime (LocalTime day tod) zone
ctimeToZonedTime :: Ptr CZoneInfo -> Ptr CTime -> Pico -> IO ZonedTime
ctimeToZonedTime zi ct psec = do
allocaBytes (44) $ \ tm -> do
c_localtime zi ct tm
ctmToZonedTime zi tm psec
newContextFinalizer :: Ptr CContext -> IO Context
newContextFinalizer =
newForeignPtr c_destroy
throwError :: String -> IO a
throwError = ioError . userError
newContext :: Maybe String -> IO Context
newContext Nothing = do
throwErrnoIfNull "Data.Time.ZoneInfo.newContext" io
io >>= newContextFinalizer
where
io = c_create nullPtr
newContext (Just s) = do
throwErrnoIfNull "Data.Time.ZoneInfo.newContext" io
io >>= newContextFinalizer
where
io = withCString s c_create
newOlsonZone :: Context -> String -> IO OlsonZone
newOlsonZone ctx s = do
io' <- throwErrnoIfNull "Data.Time.ZoneInfo.newOlsonZone" io
return $ OlsonZone ctx io'
where
ctx' = unsafeForeignPtrToPtr ctx
io = withCString s $ c_get ctx'
utcOlsonZone :: Context -> OlsonZone
utcOlsonZone ctx =
OlsonZone ctx (unsafePerformIO $ c_gmt ctx')
where
ctx' = unsafeForeignPtrToPtr ctx
class ZoneInfo a where
zoneInfoName :: a -> Bool -> IO (String)
zoneInfoMinutes :: a -> Bool -> IO Int
posixToZonedTime :: a -> POSIXTime -> IO ZonedTime
posixToZonedTime zi =
utcToZonedTime' zi . posixToUTCTime
utcToZonedTime' :: a -> UTCTime -> IO ZonedTime
utcToZonedTime' zi =
posixToZonedTime zi . utcToPOSIXTime
localToPOSIXZoned :: a -> LocalTime -> IO (POSIXTime, TimeZone)
localToPOSIXZoned zi lt = do
(ut, tz) <- localToUTCZoned zi lt
return (utcToPOSIXTime ut, tz)
localToUTCZoned :: a -> LocalTime -> IO (UTCTime, TimeZone)
localToUTCZoned zi lt = do
(pt, tz) <- localToPOSIXZoned zi lt
return (posixToUTCTime pt, tz)
convertTimeZone :: ZoneInfo b => a -> LocalTime -> b -> IO ZonedTime
convertTimeZone src lt dst = do
(pt, _) <- localToPOSIXZoned src lt
posixToZonedTime dst pt
instance ZoneInfo OlsonZone where
zoneInfoName (OlsonZone _ zi) isdst = do
c_zone zi isdst' >>= peekCString
where
isdst' = if isdst then 1 else 0
zoneInfoMinutes (OlsonZone _ zi) isdst = do
tz <- c_gmtoff zi isdst'
return $ fromIntegral $ div tz 60
where
isdst' = if isdst then 1 else 0
posixToZonedTime (OlsonZone _ zi) pt = do
with (fromInteger sec :: CTime) $ \ ct -> do
ctimeToZonedTime zi ct (realToFrac psec)
where
(sec, psec) = pt `divMod'` 1
localToPOSIXZoned (OlsonZone _ zi) lt =
allocaBytes (44) $ \ tm -> do
setCTmDay tm day
setCTmTimeOfDay tm tod
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) tm (1 :: CInt)
ct <- c_mktime zi tm
tz <- ctmToTimeZone zi tm
return (cToPOSIXTime ct psec, tz)
where
day = localDay lt
tod = localTimeOfDay lt
sec = todSec tod
psec = sec `mod'` 1
instance ZoneInfo TimeZone where
zoneInfoName tz True = do
if timeZoneSummerOnly tz then return $ timeZoneName tz
else throwError "not summer-only"
zoneInfoName tz False = do
if timeZoneSummerOnly tz then throwError "summer-only"
else return $ timeZoneName tz
zoneInfoMinutes tz True = do
if timeZoneSummerOnly tz then return $ timeZoneMinutes tz
else throwError "not summer-only"
zoneInfoMinutes tz False = do
if timeZoneSummerOnly tz then throwError "summer-only"
else return $ timeZoneMinutes tz
utcToZonedTime' tz ut = do
return $ ZonedTime (utcToLocalTime tz ut) tz
localToUTCZoned tz lt = do
return (localTimeToUTC tz lt, tz)