    {-# 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
        Int
    i0 <- LeapSecondMap
    lsmap Day
    day
        Int
    i1 <- LeapSecondMap
    lsmap LeapSecondMap -> LeapSecondMap
    forall a b. (a -> b) -> a -> b
    $ Integer -> Day -> Day
    addDays Integer
    1 Day
    day
        DiffTime -> Maybe DiffTime
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DiffTime -> Maybe DiffTime) -> DiffTime -> Maybe DiffTime
    forall a b. (a -> b) -> a -> b
    $ Int -> DiffTime
    forall a b. (Real a, Fractional b) => a -> b
    realToFrac (Int
    86400 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    i1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    i0)

    dayStart :: LeapSecondMap -> Day -> Maybe AbsoluteTime
    dayStart :: LeapSecondMap -> Day -> Maybe AbsoluteTime
    dayStart LeapSecondMap
    lsmap Day
    day = do
        Int
    i <- LeapSecondMap
    lsmap Day
    day
        AbsoluteTime -> Maybe AbsoluteTime
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (AbsoluteTime -> Maybe AbsoluteTime)
    -> AbsoluteTime -> Maybe AbsoluteTime
    forall a b. (a -> b) -> a -> b
    $ DiffTime -> AbsoluteTime -> AbsoluteTime
    addAbsoluteTime (Integer -> DiffTime
    forall a b. (Real a, Fractional b) => a -> b
    realToFrac (Integer -> DiffTime) -> Integer -> DiffTime
    forall a b. (a -> b) -> a -> b
    $ (Day -> Integer
    toModifiedJulianDay Day
    day) Integer -> Integer -> Integer
    forall a. Num a => a -> a -> a
    * Integer
    86400 Integer -> Integer -> Integer
    forall a. Num a => a -> a -> a
    + Int -> Integer
    forall a. Integral a => a -> Integer
    toInteger Int
    i) AbsoluteTime
    taiEpoch

    utcToTAITime :: LeapSecondMap -> UTCTime -> Maybe AbsoluteTime
    utcToTAITime :: LeapSecondMap -> UTCTime -> Maybe AbsoluteTime
    utcToTAITime LeapSecondMap
    lsmap (UTCTime Day
    day DiffTime
    dtime) = do
        AbsoluteTime
    t <- LeapSecondMap -> Day -> Maybe AbsoluteTime
    dayStart LeapSecondMap
    lsmap Day
    day
        AbsoluteTime -> Maybe AbsoluteTime
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (AbsoluteTime -> Maybe AbsoluteTime)
    -> AbsoluteTime -> Maybe AbsoluteTime
    forall a b. (a -> b) -> a -> b
    $ DiffTime -> AbsoluteTime -> AbsoluteTime
    addAbsoluteTime DiffTime
    dtime AbsoluteTime
    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
            AbsoluteTime
    dayt <- LeapSecondMap -> Day -> Maybe AbsoluteTime
    dayStart LeapSecondMap
    lsmap Day
    day
            DiffTime
    len <- LeapSecondMap -> Day -> Maybe DiffTime
    utcDayLength LeapSecondMap
    lsmap Day
    day
            let
                dtime :: DiffTime
    dtime = AbsoluteTime -> AbsoluteTime -> DiffTime
    diffAbsoluteTime AbsoluteTime
    abstime AbsoluteTime
    dayt
                day' :: Day
    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 Day -> Day -> Bool
    forall a. Eq a => a -> a -> Bool
    == Day
    day'
                then UTCTime -> Maybe UTCTime
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Day -> DiffTime -> UTCTime
    UTCTime Day
    day DiffTime
    dtime)
                else Day -> Maybe UTCTime
    stable Day
    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