-- | Provides access to the Olson zone-info database, using an adapted version of the Olson zone-info library.

module Data.Time.ZoneInfo (
    Olson,
    ZoneInfo,
    newOlson,
    getZoneInfo,
    utcZoneInfo,
    getZoneName,
    getZoneMinutes,
    posixToZonedTime,
    utcToZonedTime',
    localToPOSIXZoned,
    localToUTCZoned,
    convertTimeZone
) where

#include "olson.h"

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 COlson
data CZoneInfo

type Olson = ForeignPtr COlson

-- | A 'ZoneInfo' object's lifetime is bound to its 'Olson' parent.  The pair
-- includes the 'Olson' parent to ensure that it is not garbage collected
-- while the 'ZoneInfo' object is still in use.

type ZoneInfo = (Olson, Ptr CZoneInfo)

-- Foreign ctime interface.

-- struct tm

data CTm

foreign import ccall unsafe "olson_create"
  c_create :: CString -> IO (Ptr COlson)

foreign import ccall unsafe "&olson_destroy"
  c_destroy :: FunPtr (Ptr COlson -> IO ())

foreign import ccall unsafe "olson_get"
  c_get :: Ptr COlson -> CString -> IO (Ptr CZoneInfo)

foreign import ccall unsafe "olson_gmt"
  c_gmt :: Ptr COlson -> 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)

-- Private conversions.

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

-- Day

setCTmDay :: Ptr CTm -> Day -> IO ()
setCTmDay tm day = do

    (#poke struct tm,tm_year) tm (fromIntegral year - 1900 :: CInt)
    (#poke struct tm,tm_mon) tm (fromIntegral mon - 1 :: CInt)
    (#poke struct tm,tm_mday) tm (fromIntegral mday :: CInt)
    return ()

  where
    (year, mon, mday) = toGregorian day

getCTmDay :: Ptr CTm -> IO Day
getCTmDay tm = do

    year <- (#peek struct tm,tm_year) tm :: IO CInt
    mon <- (#peek struct tm,tm_mon) tm :: IO CInt
    mday <- (#peek struct tm,tm_mday) tm :: IO CInt

    return $ fromGregorian (fromIntegral year + 1900)
              (fromIntegral mon + 1) (fromIntegral mday)

-- TimeOfDay

setCTmTimeOfDay :: Ptr CTm -> TimeOfDay -> IO ()
setCTmTimeOfDay tm tod = do

    (#poke struct tm,tm_hour) tm (fromIntegral hour :: CInt)
    (#poke struct tm,tm_min) tm (fromIntegral min' :: CInt)
    (#poke struct tm,tm_sec) 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 <- (#peek struct tm,tm_hour) tm :: IO CInt
    min' <- (#peek struct tm,tm_min) tm :: IO CInt
    sec <- (#peek struct tm,tm_sec) tm :: IO CInt

    return $ TimeOfDay (fromIntegral hour) (fromIntegral min')
               (toPico sec psec)

-- TimeZone

getCTmTimeZone :: Ptr CZoneInfo -> Ptr CTm -> IO TimeZone
getCTmTimeZone zi tm = do

    isdst <- (#peek struct tm,tm_isdst) tm :: IO CInt
    gmtoff <- c_gmtoff zi isdst
    zone <- c_zone zi isdst >>= peekCString

    return $ TimeZone (fromIntegral $ div gmtoff 60) (isdst /= 0) zone

-- ZonedTime

ctmToZonedTime :: Ptr CZoneInfo -> Ptr CTm -> Pico -> IO ZonedTime
ctmToZonedTime zi tm psec = do

    day <- getCTmDay tm
    tod <- getCTmTimeOfDay tm psec
    zone <- getCTmTimeZone zi tm

    return $ ZonedTime (LocalTime day tod) zone

-- CTime

ctimeToZonedTime :: Ptr CZoneInfo -> Ptr CTime -> Pico -> IO ZonedTime
ctimeToZonedTime zi ct psec = do
    allocaBytes (#const sizeof(struct tm)) $ \ tm -> do
                                c_localtime zi ct tm
                                ctmToZonedTime zi tm psec

-- Olson finalizer.

newOlsonFinalizer :: Ptr COlson -> IO Olson
newOlsonFinalizer =
    newForeignPtr c_destroy

-- Exports.

-- | Create a new 'Olson' context object.  A path to the zone-info database
-- may be specified.  Otherwise, the TZDIR environment variable, or a
-- reasonable default, will be used.  An 'IOError' will be thrown on failure.

newOlson :: Maybe String -> IO Olson

newOlson Nothing = do
    throwErrnoIfNull "Data.Time.ZoneInfo.newOlson" io
    io >>= newOlsonFinalizer
  where
    io = c_create nullPtr

newOlson (Just s) = do
    throwErrnoIfNull "Data.Time.ZoneInfo.newOlson" io
    io >>= newOlsonFinalizer
  where
    io = withCString s c_create

-- | Obtain a 'ZoneInfo' object based on the specified Olson identifier or
-- time-zone.  If the zone-info database cannot be found, or the time-zone not
-- recognised, then an 'IOError' will be thrown.  Calls to this function must
-- be serialised across multiple threads.

getZoneInfo :: Olson -> String -> IO ZoneInfo
getZoneInfo ols s = do
    io' <- throwErrnoIfNull "Data.Time.ZoneInfo.getZoneInfo" io
    return (ols, io')
  where
    ols' = unsafeForeignPtrToPtr ols
    io = withCString s $ c_get ols'

-- | 'ZoneInfo' for the UTC time-zone.

utcZoneInfo :: Olson -> ZoneInfo
utcZoneInfo ols =
    (ols, unsafePerformIO $ c_gmt ols')
  where
    ols' = unsafeForeignPtrToPtr ols

-- | Returns the zone-name for either the standard or daylight saving zone,
-- depending on the 'isdst' argument.

getZoneName :: ZoneInfo -> Bool -> IO (String)
getZoneName (_, zi) isdst = do
    c_zone zi isdst' >>= peekCString
  where
    isdst' = if isdst then 1 else 0

-- | Returns the UTC offset for either the standard or daylight saving zone,
-- depending on the 'isdst' argument.

getZoneMinutes :: ZoneInfo -> Bool -> IO Int
getZoneMinutes (_, zi) isdst = do
    tz <- c_gmtoff zi isdst'
    return $ fromIntegral $ div tz 60
  where
    isdst' = if isdst then 1 else 0

-- | Convert from 'POSIXTime' to zoned 'LocalTime'.

posixToZonedTime :: ZoneInfo -> POSIXTime -> IO ZonedTime
posixToZonedTime (_, zi) pt = do

  -- "with" creates a Ptr CTime.

    with (fromInteger sec :: CTime) $ \ ct -> do
                           ctimeToZonedTime zi ct (realToFrac psec)
  where
    (sec, psec) = divMod' pt 1

-- | Convert from 'UTCTime' to zoned 'LocalTime'.

utcToZonedTime' :: ZoneInfo -> UTCTime -> IO ZonedTime
utcToZonedTime' zi =
   posixToZonedTime zi . utcToPOSIXTime

-- | Convert 'LocalTime' to a daylight saving adjusted pair.

localToPOSIXZoned :: ZoneInfo -> LocalTime -> IO (POSIXTime, ZonedTime)
localToPOSIXZoned (_, zi) lt =
    allocaBytes (#const sizeof(struct tm)) $ \ tm -> do
      setCTmDay tm day
      setCTmTimeOfDay tm tod
      (#poke struct tm,tm_isdst) tm (-1 :: CInt)
      ct <- c_mktime zi tm
      zt <- ctmToZonedTime zi tm psec
      return (cToPOSIXTime ct psec, zt)
  where
    day = localDay lt
    tod = localTimeOfDay lt
    sec = todSec tod
    psec = mod' sec 1

-- | Convert 'LocalTime' to a daylight saving adjusted pair.

localToUTCZoned :: ZoneInfo -> LocalTime -> IO (UTCTime, ZonedTime)
localToUTCZoned zi lt = do
    (pt, zi') <- localToPOSIXZoned zi lt
    return (posixToUTCTime pt, zi')

-- | Convert the 'LocalTime' argument from the source to destination
-- 'TimeZone'.

convertTimeZone :: ZoneInfo -> LocalTime -> ZoneInfo -> IO ZonedTime
convertTimeZone src lt dst = do
    (pt, _) <- localToPOSIXZoned src lt
    posixToZonedTime dst pt