{-# 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 = forall a. Show a => a -> String
show (TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
utc (forall a. HasCallStack => Maybe a -> a
fromJust (LeapSecondMap -> AbsoluteTime -> Maybe UTCTime
taiToUTCTime (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just Int
0)) AbsoluteTime
t))) 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 forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
day
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Real a, Fractional b) => a -> b
realToFrac (Int
86400 forall a. Num a => a -> a -> a
+ Int
i1 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DiffTime -> AbsoluteTime -> AbsoluteTime
addAbsoluteTime (forall a b. (Real a, Fractional b) => a -> b
realToFrac forall a b. (a -> b) -> a -> b
$ (Day -> Integer
toModifiedJulianDay Day
day) forall a. Num a => a -> a -> a
* Integer
86400 forall a. Num a => a -> a -> a
+ 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
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 (forall a b. (Real a, Integral b) => a -> a -> b
div' DiffTime
dtime DiffTime
len) Day
day
        if Day
day forall a. Eq a => a -> a -> Bool
== Day
day'
            then 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 forall a b. (a -> b) -> a -> b
$ Integer -> Day
ModifiedJulianDay forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SystemTime -> AbsoluteTime
systemToTAITime)) Maybe (DiffTime, IO SystemTime)
getTAISystemTime