{-# LANGUAGE Safe #-}

{-# OPTIONS -fno-warn-orphans #-}

-- | TAI and leap-second maps for converting to UTC: most people won't need this module.
module Data.Time.Clock.TAI (
    -- TAI arithmetic
    module Data.Time.Clock.Internal.AbsoluteTime,
    -- leap-second map type
    LeapSecondMap,
    -- conversion between UTC and TAI with map
    utcDayLength,
    utcToTAITime,
    taiToUTCTime,
    taiClock,
) where

import Data.Fixed
import Data.Maybe
import Data.Time.Calendar.Days
import Data.Time.Clock
import Data.Time.Clock.Internal.AbsoluteTime
import Data.Time.Clock.Internal.SystemTime
import Data.Time.Clock.System
import Data.Time.LocalTime

instance Show AbsoluteTime where
    show :: AbsoluteTime -> String
show AbsoluteTime
t = LocalTime -> String
forall a. Show a => a -> String
show (TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
utc (Maybe UTCTime -> UTCTime
forall a. HasCallStack => Maybe a -> a
fromJust (LeapSecondMap -> AbsoluteTime -> Maybe UTCTime
taiToUTCTime (Maybe Int -> LeapSecondMap
forall a b. a -> b -> a
const (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)) AbsoluteTime
t))) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" TAI" -- ugly, but standard apparently

-- | TAI - UTC during this day.
-- No table is provided, as any program compiled with it would become
-- out of date in six months.
type LeapSecondMap = Day -> Maybe Int

utcDayLength :: LeapSecondMap -> Day -> Maybe DiffTime
utcDayLength :: LeapSecondMap -> Day -> Maybe DiffTime
utcDayLength LeapSecondMap
lsmap Day
day = do
    i0 <- LeapSecondMap
lsmap Day
day
    i1 <- lsmap $ addDays 1 day
    return $ realToFrac (86400 + i1 - i0)

dayStart :: LeapSecondMap -> Day -> Maybe AbsoluteTime
dayStart :: LeapSecondMap -> Day -> Maybe AbsoluteTime
dayStart LeapSecondMap
lsmap Day
day = do
    i <- LeapSecondMap
lsmap Day
day
    return $ addAbsoluteTime (realToFrac $ (toModifiedJulianDay day) * 86400 + toInteger i) taiEpoch

utcToTAITime :: LeapSecondMap -> UTCTime -> Maybe AbsoluteTime
utcToTAITime :: LeapSecondMap -> UTCTime -> Maybe AbsoluteTime
utcToTAITime LeapSecondMap
lsmap (UTCTime Day
day DiffTime
dtime) = do
    t <- LeapSecondMap -> Day -> Maybe AbsoluteTime
dayStart LeapSecondMap
lsmap Day
day
    return $ addAbsoluteTime dtime t

taiToUTCTime :: LeapSecondMap -> AbsoluteTime -> Maybe UTCTime
taiToUTCTime :: LeapSecondMap -> AbsoluteTime -> Maybe UTCTime
taiToUTCTime LeapSecondMap
lsmap AbsoluteTime
abstime = let
    stable :: Day -> Maybe UTCTime
stable Day
day = do
        dayt <- LeapSecondMap -> Day -> Maybe AbsoluteTime
dayStart LeapSecondMap
lsmap Day
day
        len <- utcDayLength lsmap day
        let
            dtime = AbsoluteTime -> AbsoluteTime -> DiffTime
diffAbsoluteTime AbsoluteTime
abstime AbsoluteTime
dayt
            day' = Integer -> Day -> Day
addDays (DiffTime -> DiffTime -> Integer
forall a b. (Real a, Integral b) => a -> a -> b
div' DiffTime
dtime DiffTime
len) Day
day
        if day == day'
            then return (UTCTime day dtime)
            else stable day'
    in Day -> Maybe UTCTime
stable (Day -> Maybe UTCTime) -> Day -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ Integer -> Day
ModifiedJulianDay (Integer -> Day) -> Integer -> Day
forall a b. (a -> b) -> a -> b
$ DiffTime -> DiffTime -> Integer
forall a b. (Real a, Integral b) => a -> a -> b
div' (AbsoluteTime -> AbsoluteTime -> DiffTime
diffAbsoluteTime AbsoluteTime
abstime AbsoluteTime
taiEpoch) DiffTime
86400

-- | TAI clock, if it exists. Note that it is unlikely to be set correctly, without due care and attention.
taiClock :: Maybe (DiffTime, IO AbsoluteTime)
taiClock :: Maybe (DiffTime, IO AbsoluteTime)
taiClock = ((DiffTime, IO SystemTime) -> (DiffTime, IO AbsoluteTime))
-> Maybe (DiffTime, IO SystemTime)
-> Maybe (DiffTime, IO AbsoluteTime)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IO SystemTime -> IO AbsoluteTime)
-> (DiffTime, IO SystemTime) -> (DiffTime, IO AbsoluteTime)
forall a b. (a -> b) -> (DiffTime, a) -> (DiffTime, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SystemTime -> AbsoluteTime) -> IO SystemTime -> IO AbsoluteTime
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SystemTime -> AbsoluteTime
systemToTAITime)) Maybe (DiffTime, IO SystemTime)
getTAISystemTime