{-# 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