{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

#include "thyme.h"
#if HLINT
#include "cabal_macros.h"
#endif

module Data.Thyme.Clock.TAI
    ( AbsoluteTime
    , taiEpoch
    , LeapSecondTable
    , utcDayLength
    , absoluteTime
    , parseTAIUTCDAT
    ) where

import Prelude
import Control.Applicative
import Control.DeepSeq
import Control.Lens
import Control.Monad
import Data.AffineSpace
import Data.Attoparsec.ByteString.Char8 ((<?>))
import qualified Data.Attoparsec.ByteString.Char8 as P
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import Data.Char
import Data.Data
import Data.Either
import Data.Ix
#if MIN_VERSION_containers(0,5,0)
import qualified Data.Map.Strict as Map
#else
import qualified Data.Map as Map
#endif
import Data.Thyme.Calendar
import Data.Thyme.Clock.Internal
import Data.Thyme.Format.Internal
import Data.Thyme.LocalTime
#if __GLASGOW_HASKELL__ == 704
import qualified Data.Vector.Generic
import qualified Data.Vector.Generic.Mutable
#endif
import Data.Vector.Unboxed.Deriving
import Data.VectorSpace
import GHC.Generics (Generic)
import System.Locale
import System.Random (Random)
import Test.QuickCheck

newtype AbsoluteTime = AbsoluteTime DiffTime deriving (INSTANCES_MICRO)

derivingUnbox "AbsoluteTime" [t| AbsoluteTime -> DiffTime |]
    [| \ (AbsoluteTime a) -> a |] [| AbsoluteTime |]

instance Show AbsoluteTime where
    {-# INLINEABLE showsPrec #-}
    showsPrec :: Int -> AbsoluteTime -> ShowS
showsPrec p :: Int
p tai :: AbsoluteTime
tai = Int -> LocalTime -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p LocalTime
lt ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) " TAI" where
        lt :: LocalTime
lt = AbsoluteTime
tai AbsoluteTime
-> Getting LocalTime AbsoluteTime LocalTime -> LocalTime
forall s a. s -> Getting a s a -> a
^. AnIso UTCTime UTCTime AbsoluteTime AbsoluteTime
-> Iso AbsoluteTime AbsoluteTime UTCTime UTCTime
forall s t a b. AnIso s t a b -> Iso b a t s
from (LeapSecondTable -> Iso' UTCTime AbsoluteTime
absoluteTime (DiffTime -> LeapSecondTable
forall a b. a -> b -> a
const DiffTime
forall v. AdditiveGroup v => v
zeroV)) Overloaded
  (->) (Const LocalTime) AbsoluteTime AbsoluteTime UTCTime UTCTime
-> ((LocalTime -> Const LocalTime LocalTime)
    -> UTCTime -> Const LocalTime UTCTime)
-> Getting LocalTime AbsoluteTime LocalTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeZone -> Iso' UTCTime LocalTime
utcLocalTime TimeZone
utc

-- | The epoch of TAI, which is 1858-11-17 00:00:00 TAI.
{-# INLINE taiEpoch #-}
taiEpoch :: AbsoluteTime
taiEpoch :: AbsoluteTime
taiEpoch = DiffTime -> AbsoluteTime
AbsoluteTime DiffTime
forall v. AdditiveGroup v => v
zeroV

instance AffineSpace AbsoluteTime where
    type Diff AbsoluteTime = DiffTime
    {-# INLINE (.-.) #-}
    .-. :: AbsoluteTime -> AbsoluteTime -> Diff AbsoluteTime
(.-.) = \ (AbsoluteTime a :: DiffTime
a) (AbsoluteTime b :: DiffTime
b) -> DiffTime
a DiffTime -> DiffTime -> DiffTime
forall v. AdditiveGroup v => v -> v -> v
^-^ DiffTime
b
    {-# INLINE (.+^) #-}
    .+^ :: AbsoluteTime -> Diff AbsoluteTime -> AbsoluteTime
(.+^) = \ (AbsoluteTime a :: DiffTime
a) d :: Diff AbsoluteTime
d -> DiffTime -> AbsoluteTime
AbsoluteTime (DiffTime
a DiffTime -> DiffTime -> DiffTime
forall v. AdditiveGroup v => v -> v -> v
^+^ Diff AbsoluteTime
DiffTime
d)

type LeapSecondTable = Either UTCTime AbsoluteTime -> DiffTime

utcDayLength :: LeapSecondTable -> Day -> DiffTime
utcDayLength :: LeapSecondTable -> Day -> DiffTime
utcDayLength table :: LeapSecondTable
table day :: Day
day@((Day -> Diff Day -> Day
forall p. AffineSpace p => p -> Diff p -> p
.+^ 1) -> Day
next) =
        Micro -> DiffTime
DiffTime Micro
posixDay DiffTime -> DiffTime -> DiffTime
forall v. AdditiveGroup v => v -> v -> v
^+^ Day -> DiffTime
diff Day
next DiffTime -> DiffTime -> DiffTime
forall v. AdditiveGroup v => v -> v -> v
^-^ Day -> DiffTime
diff Day
day where
    diff :: Day -> DiffTime
diff d :: Day
d = LeapSecondTable
table LeapSecondTable
-> (UTCTime -> Either UTCTime AbsoluteTime) -> UTCTime -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Either UTCTime AbsoluteTime
forall a b. a -> Either a b
Left (UTCTime -> DiffTime) -> UTCTime -> DiffTime
forall a b. (a -> b) -> a -> b
$ Overloaded Reviewed Identity UTCTime UTCTime UTCView UTCView
Iso' UTCTime UTCView
utcTime Overloaded Reviewed Identity UTCTime UTCTime UTCView UTCView
-> UTCView -> UTCTime
forall s t a b. AReview s t a b -> b -> t
# Day -> DiffTime -> UTCView
UTCTime Day
d DiffTime
forall v. AdditiveGroup v => v
zeroV
    NominalDiffTime posixDay :: Micro
posixDay = NominalDiffTime
posixDayLength

{-# INLINE absoluteTime #-}
absoluteTime :: LeapSecondTable -> Iso' UTCTime AbsoluteTime
absoluteTime :: LeapSecondTable -> Iso' UTCTime AbsoluteTime
absoluteTime table :: LeapSecondTable
table = (UTCTime -> AbsoluteTime)
-> (AbsoluteTime -> UTCTime) -> Iso' UTCTime AbsoluteTime
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso UTCTime -> AbsoluteTime
toTAI AbsoluteTime -> UTCTime
fromTAI where

    {-# INLINE toTAI #-}
    toTAI :: UTCTime -> AbsoluteTime
    toTAI :: UTCTime -> AbsoluteTime
toTAI ut :: UTCTime
ut@(UTCRep (NominalDiffTime u :: Micro
u)) =
        DiffTime -> AbsoluteTime
AbsoluteTime (Micro -> DiffTime
DiffTime Micro
u DiffTime -> DiffTime -> DiffTime
forall v. AdditiveGroup v => v -> v -> v
^+^ LeapSecondTable
table (UTCTime -> Either UTCTime AbsoluteTime
forall a b. a -> Either a b
Left UTCTime
ut))

    {-# INLINE fromTAI #-}
    fromTAI :: AbsoluteTime -> UTCTime
    fromTAI :: AbsoluteTime -> UTCTime
fromTAI tai :: AbsoluteTime
tai@(AbsoluteTime a :: DiffTime
a) = NominalDiffTime -> UTCTime
UTCRep (Micro -> NominalDiffTime
NominalDiffTime Micro
u) where
        DiffTime u :: Micro
u = DiffTime
a DiffTime -> DiffTime -> DiffTime
forall v. AdditiveGroup v => v -> v -> v
^-^ LeapSecondTable
table (AbsoluteTime -> Either UTCTime AbsoluteTime
forall a b. b -> Either a b
Right AbsoluteTime
tai)

-- | @tai-utc.dat@ from <http://maia.usno.navy.mil/ser7/tai-utc.dat>
{-# INLINEABLE parseTAIUTCDAT #-}
parseTAIUTCDAT :: ByteString -> LeapSecondTable
parseTAIUTCDAT :: ByteString -> LeapSecondTable
parseTAIUTCDAT = Parser
  ((UTCTime, UTCTime -> DiffTime),
   (AbsoluteTime, AbsoluteTime -> DiffTime))
-> ByteString -> LeapSecondTable
forall c a a.
(AdditiveGroup c, Ord a, Ord a) =>
Parser ((a, a -> c), (a, a -> c)) -> ByteString -> Either a a -> c
parse (Parser
   ((UTCTime, UTCTime -> DiffTime),
    (AbsoluteTime, AbsoluteTime -> DiffTime))
 -> ByteString -> LeapSecondTable)
-> Parser
     ((UTCTime, UTCTime -> DiffTime),
      (AbsoluteTime, AbsoluteTime -> DiffTime))
-> ByteString
-> LeapSecondTable
forall a b. (a -> b) -> a -> b
$ do
    Int
y <- Int -> Parser Int
dec_ 5 Parser Int -> Parser ByteString () -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
P.skipSpace Parser Int -> String -> Parser Int
forall i a. Parser i a -> String -> Parser i a
<?> "Year"
    let mons :: [String]
mons = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper ShowS -> ((String, String) -> String) -> (String, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> b
snd ((String, String) -> String) -> [(String, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TimeLocale -> [(String, String)]
months TimeLocale
defaultTimeLocale
    Int
m <- Int -> Int
forall a. Enum a => a -> a
succ (Int -> Int) -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Parser Int
indexOf [String]
mons Parser Int -> Parser ByteString () -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
P.skipSpace Parser Int -> String -> Parser Int
forall i a. Parser i a -> String -> Parser i a
<?> "Month"
    Int
d <- Int -> Parser Int
dec_ 2 Parser Int -> String -> Parser Int
forall i a. Parser i a -> String -> Parser i a
<?> "Day"
    [ByteString] -> Parser ByteString ()
tokens ["=", "JD"]
    -- TAI-UTC changes always happen at midnight, so just ignore ".5".
    Int
mjd <- Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract 2400000{-.5-} (Int -> Int) -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
forall a. Integral a => Parser a
P.decimal
        Parser Int -> Parser ByteString ByteString -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString ByteString
P.string ".5" Parser Int -> String -> Parser Int
forall i a. Parser i a -> String -> Parser i a
<?> "Julian Date .5"
    let ymd :: YearMonthDay
ymd = Int -> Int -> Int -> YearMonthDay
YearMonthDay Int
y Int
m Int
d
    Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Overloaded Reviewed Identity Day Day YearMonthDay YearMonthDay
Iso' Day YearMonthDay
gregorian Overloaded Reviewed Identity Day Day YearMonthDay YearMonthDay
-> YearMonthDay -> Day
forall s t a b. AReview s t a b -> b -> t
# YearMonthDay
ymd Day -> Day -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Day
ModifiedJulianDay Int
mjd) (Parser ByteString () -> Parser ByteString ())
-> (String -> Parser ByteString ())
-> String
-> Parser ByteString ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString ()) -> String -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$
        YearMonthDay -> String
forall a. Show a => a -> String
show YearMonthDay
ymd String -> ShowS
forall a. [a] -> [a] -> [a]
++ " is not Modified Julian Day " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
mjd

    [ByteString] -> Parser ByteString ()
tokens ["TAI", "-", "UTC", "="]
    Rational
b <- Parser Rational
forall a. Fractional a => Parser a
P.rational Parser Rational -> String -> Parser Rational
forall i a. Parser i a -> String -> Parser i a
<?> "Base"
    [ByteString] -> Parser ByteString ()
tokens ["S", "+", "(", "MJD", "-"]
    Rational
o <- Parser Rational
forall a. Fractional a => Parser a
P.rational Parser Rational -> String -> Parser Rational
forall i a. Parser i a -> String -> Parser i a
<?> "Offset"
    [ByteString] -> Parser ByteString ()
tokens [".", ")", "X"]
    Rational
c <- Parser Rational
forall a. Fractional a => Parser a
P.rational Parser Rational -> Parser ByteString () -> Parser Rational
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* [ByteString] -> Parser ByteString ()
tokens ["S"] Parser Rational -> String -> Parser Rational
forall i a. Parser i a -> String -> Parser i a
<?> "Coefficient"

    -- FIXME: confirm UTC↔TAI conversion for pre-1972.
    -- Do we round MJD? This is a guess:
    -- TAI-UTC =  b + c * (MJD(UTC) - o)
    let atUTC :: UTCTime -> DiffTime
atUTC (UTCRep t :: NominalDiffTime
t) = Rational -> DiffTime
forall t. TimeDiff t => Rational -> t
fromSeconds' (Rational -> DiffTime) -> Rational -> DiffTime
forall a b. (a -> b) -> a -> b
$ Rational
b Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
c Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (NominalDiffTime -> Rational
forall a t. (Fractional a, TimeDiff t) => t -> a
toMJD NominalDiffTime
t Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
o)
    -- TAI-UTC = (b + c * (MJD(TAI) - o)) / (1 + c)
    let atTAI :: AbsoluteTime -> DiffTime
atTAI (AbsoluteTime t :: DiffTime
t) = Rational -> DiffTime
forall t. TimeDiff t => Rational -> t
fromSeconds' (Rational -> DiffTime) -> Rational -> DiffTime
forall a b. (a -> b) -> a -> b
$ Rational
b Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
c Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (DiffTime -> Rational
forall a t. (Fractional a, TimeDiff t) => t -> a
toMJD DiffTime
t Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
o) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ (1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
c)
    let NominalDiffTime ((Int -> Rational
forall a. Real a => a -> Rational
toRational Int
mjd Scalar Micro -> Micro -> Micro
forall v. VectorSpace v => Scalar v -> v -> v
*^) -> Micro
begin) = NominalDiffTime
posixDayLength
    let beginUTC :: UTCTime
beginUTC = NominalDiffTime -> UTCTime
UTCRep (Micro -> NominalDiffTime
NominalDiffTime Micro
begin)
    let beginTAI :: AbsoluteTime
beginTAI = DiffTime -> AbsoluteTime
AbsoluteTime (Micro -> DiffTime
DiffTime Micro
begin DiffTime -> DiffTime -> DiffTime
forall v. AdditiveGroup v => v -> v -> v
^-^ UTCTime -> DiffTime
atUTC UTCTime
beginUTC)
    ((UTCTime, UTCTime -> DiffTime),
 (AbsoluteTime, AbsoluteTime -> DiffTime))
-> Parser
     ((UTCTime, UTCTime -> DiffTime),
      (AbsoluteTime, AbsoluteTime -> DiffTime))
forall (m :: * -> *) a. Monad m => a -> m a
return ((UTCTime
beginUTC, UTCTime -> DiffTime
atUTC), (AbsoluteTime
beginTAI, AbsoluteTime -> DiffTime
atTAI))

  where
    toMJD :: t -> a
toMJD t :: t
t = t -> a
forall t n. (TimeDiff t, Fractional n) => t -> n
toSeconds t
t a -> a -> a
forall a. Fractional a => a -> a -> a
/ NominalDiffTime -> a
forall t n. (TimeDiff t, Fractional n) => t -> n
toSeconds NominalDiffTime
posixDayLength
    tokens :: [ByteString] -> Parser ByteString ()
tokens = (ByteString -> Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> [ByteString] -> Parser ByteString ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ tok :: ByteString
tok a :: Parser ByteString ()
a -> Parser ByteString ()
P.skipSpace Parser ByteString ()
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Parser ByteString ByteString
P.string ByteString
tok Parser ByteString ByteString
-> Parser ByteString () -> Parser ByteString ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString ()
a) Parser ByteString ()
P.skipSpace

    parse :: Parser ((a, a -> c), (a, a -> c)) -> ByteString -> Either a a -> c
parse row :: Parser ((a, a -> c), (a, a -> c))
row = ([(a, a -> c)], [(a, a -> c)]) -> Either a a -> c
forall c a a.
(AdditiveGroup c, Ord a, Ord a) =>
([(a, a -> c)], [(a, a -> c)]) -> Either a a -> c
pair (([(a, a -> c)], [(a, a -> c)]) -> Either a a -> c)
-> (ByteString -> ([(a, a -> c)], [(a, a -> c)]))
-> ByteString
-> Either a a
-> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((a, a -> c), (a, a -> c))] -> ([(a, a -> c)], [(a, a -> c)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((a, a -> c), (a, a -> c))] -> ([(a, a -> c)], [(a, a -> c)]))
-> (ByteString -> [((a, a -> c), (a, a -> c))])
-> ByteString
-> ([(a, a -> c)], [(a, a -> c)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either String ((a, a -> c), (a, a -> c))]
-> [((a, a -> c), (a, a -> c))]
forall a b. [Either a b] -> [b]
rights ([Either String ((a, a -> c), (a, a -> c))]
 -> [((a, a -> c), (a, a -> c))])
-> (ByteString -> [Either String ((a, a -> c), (a, a -> c))])
-> ByteString
-> [((a, a -> c), (a, a -> c))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Either String ((a, a -> c), (a, a -> c)))
-> [ByteString] -> [Either String ((a, a -> c), (a, a -> c))]
forall a b. (a -> b) -> [a] -> [b]
map (Parser ((a, a -> c), (a, a -> c))
-> ByteString -> Either String ((a, a -> c), (a, a -> c))
forall a. Parser a -> ByteString -> Either String a
P.parseOnly Parser ((a, a -> c), (a, a -> c))
row) ([ByteString] -> [Either String ((a, a -> c), (a, a -> c))])
-> (ByteString -> [ByteString])
-> ByteString
-> [Either String ((a, a -> c), (a, a -> c))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
S.lines
    pair :: ([(a, a -> c)], [(a, a -> c)]) -> Either a a -> c
pair ([(a, a -> c)] -> a -> c
forall b a. (AdditiveGroup b, Ord a) => [(a, a -> b)] -> a -> b
look -> a -> c
atUTC, [(a, a -> c)] -> a -> c
forall b a. (AdditiveGroup b, Ord a) => [(a, a -> b)] -> a -> b
look -> a -> c
atTAI) = (a -> c) -> (a -> c) -> Either a a -> c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> c
atUTC a -> c
atTAI
#if MIN_VERSION_containers(0,5,0)
    look :: [(a, a -> b)] -> a -> b
look l :: [(a, a -> b)]
l = \ t :: a
t -> b -> ((a, a -> b) -> b) -> Maybe (a, a -> b) -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
forall v. AdditiveGroup v => v
zeroV (((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
t) ((a -> b) -> b) -> ((a, a -> b) -> a -> b) -> (a, a -> b) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a -> b) -> a -> b
forall a b. (a, b) -> b
snd) (Maybe (a, a -> b) -> b) -> Maybe (a, a -> b) -> b
forall a b. (a -> b) -> a -> b
$ a -> Map a (a -> b) -> Maybe (a, a -> b)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupLE a
t ([(a, a -> b)] -> Map a (a -> b)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(a, a -> b)]
l)
#else
    look l = \ t -> case Map.splitLookup t (Map.fromList l) of
        (lt, eq, _) -> maybe zeroV ($ t) $ eq <|> fst <$> Map.maxView lt
#endif