{-# LINE 1 "Data/Time/ZoneInfo.hsc" #-}
-- | Provides access to the Olson zone-info database, using an adapted version of the Olson zone-info library.
{-# LINE 2 "Data/Time/ZoneInfo.hsc" #-}

module Data.Time.ZoneInfo (
    Olson,
    ZoneInfo (..),
    newOlson,
    newOlsonZone,
    utcOlsonZone,
) where


{-# LINE 12 "Data/Time/ZoneInfo.hsc" #-}

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

-- | An 'Olson' object must outlive any child 'OlsonZone' objects.  This pair
-- includes the 'Olson' parent to ensure that it is not garbage collected
-- while the 'CZoneInfo' object is still in use.

data OlsonZone = OlsonZone 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.

-- | Pico seconds from seconds and fractional pico seconds.

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

    ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) tm (fromIntegral year - 1900 :: CInt)
{-# LINE 89 "Data/Time/ZoneInfo.hsc" #-}
    ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) tm (fromIntegral mon - 1 :: CInt)
{-# LINE 90 "Data/Time/ZoneInfo.hsc" #-}
    ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) tm (fromIntegral mday :: CInt)
{-# LINE 91 "Data/Time/ZoneInfo.hsc" #-}
    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
{-# LINE 100 "Data/Time/ZoneInfo.hsc" #-}
    mon <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) tm :: IO CInt
{-# LINE 101 "Data/Time/ZoneInfo.hsc" #-}
    mday <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) tm :: IO CInt
{-# LINE 102 "Data/Time/ZoneInfo.hsc" #-}

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

-- TimeOfDay

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

    ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) tm (fromIntegral hour :: CInt)
{-# LINE 112 "Data/Time/ZoneInfo.hsc" #-}
    ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) tm (fromIntegral min' :: CInt)
{-# LINE 113 "Data/Time/ZoneInfo.hsc" #-}
    ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) tm (truncate sec :: CInt)
{-# LINE 114 "Data/Time/ZoneInfo.hsc" #-}

    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
{-# LINE 126 "Data/Time/ZoneInfo.hsc" #-}
    min' <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) tm :: IO CInt
{-# LINE 127 "Data/Time/ZoneInfo.hsc" #-}
    sec <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) tm :: IO CInt
{-# LINE 128 "Data/Time/ZoneInfo.hsc" #-}

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

-- TimeZone

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

    isdst <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) tm :: IO CInt
{-# LINE 138 "Data/Time/ZoneInfo.hsc" #-}
    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 <- ctmToTimeZone zi tm

    return $ ZonedTime (LocalTime day tod) zone

-- CTime

ctimeToZonedTime :: Ptr CZoneInfo -> Ptr CTime -> Pico -> IO ZonedTime
ctimeToZonedTime zi ct psec = do
    allocaBytes (44) $ \ tm -> do
{-# LINE 159 "Data/Time/ZoneInfo.hsc" #-}
                                c_localtime zi ct tm
                                ctmToZonedTime zi tm psec

-- Olson finalizer.

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

throwError :: String -> IO a
throwError = ioError . userError

-- Exports.

-- | Create an '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 an 'OlsonZone' 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 for a
-- given 'Olson' object must be serialised across threads.

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

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

utcOlsonZone :: Olson -> OlsonZone
utcOlsonZone ols =
    OlsonZone ols (unsafePerformIO $ c_gmt ols')
  where
    ols' = unsafeForeignPtrToPtr ols

class ZoneInfo a where

    -- | Returns the zone-name for either the standard or daylight saving
    -- zone, depending on the 'isdst' boolean argument; an 'IOError' will be
    -- thrown if this information is unavailable.

    zoneInfoName :: a -> Bool -> IO (String)

    -- | Returns the UTC offset for either the standard or daylight saving
    -- zone, depending on the 'isdst' boolean argument; an 'IOError' will be
    -- thrown if this information is unavailable.

    zoneInfoMinutes :: a -> Bool -> IO Int

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

    posixToZonedTime :: a -> POSIXTime -> IO ZonedTime
    posixToZonedTime zi =
        utcToZonedTime' zi . posixToUTCTime

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

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

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

    localToPOSIXZoned :: a -> LocalTime -> IO (POSIXTime, TimeZone)
    localToPOSIXZoned zi lt = do
        (ut, tz) <- localToUTCZoned zi lt
        return (utcToPOSIXTime ut, tz)

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

    localToUTCZoned :: a -> LocalTime -> IO (UTCTime, TimeZone)
    localToUTCZoned zi lt = do
        (pt, tz) <- localToPOSIXZoned zi lt
        return (posixToUTCTime pt, tz)

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

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

-- | 'OlsonZone' implementation.

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" creates a Ptr CTime.

        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
{-# LINE 286 "Data/Time/ZoneInfo.hsc" #-}
          setCTmDay tm day
          setCTmTimeOfDay tm tod
          ((\hsc_ptr -> pokeByteOff hsc_ptr 32)) tm (-1 :: CInt)
{-# LINE 289 "Data/Time/ZoneInfo.hsc" #-}
          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

-- | 'TimeZone' implementation.

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)