{-# 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
#define TAIUTCDAT @<http://maia.usno.navy.mil/ser7/tai-utc.dat tai-utc.dat>@
module Data.Thyme.Clock.TAI
( AbsoluteTime
, taiEpoch
, TAIUTCMap (..)
, TAIUTCRow (..)
, absoluteTime
, absoluteTime'
, utcDayLength
, parseTAIUTCRow
, makeTAIUTCMap
, parseTAIUTCDAT
, addAbsoluteTime
, diffAbsoluteTime
, utcToTAITime
, taiToUTCTime
) where
import Prelude
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
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 qualified Data.ByteString as S
import Data.Data
import Data.Hashable
import Data.Ix
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Thyme.Calendar
import Data.Thyme.Clock.Internal
import Data.Thyme.Format.Internal (indexOf)
import Data.Thyme.Internal.Micro
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.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 :: Year -> AbsoluteTime -> ShowS
showsPrec Year
p AbsoluteTime
tai = forall a. Show a => Year -> a -> ShowS
showsPrec Year
p LocalTime
lt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a] -> [a]
(++) [Char]
" TAI" where
lt :: LocalTime
lt = AbsoluteTime
tai forall s a. s -> Getting a s a -> a
^. forall s t a b. AnIso s t a b -> Iso b a t s
from (TAIUTCMap -> Iso' UTCTime AbsoluteTime
absoluteTime forall a b. (a -> b) -> a -> b
$ Map UTCTime TAIUTCRow -> Map AbsoluteTime TAIUTCRow -> TAIUTCMap
TAIUTCMap forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeZone -> Iso' UTCTime LocalTime
utcLocalTime TimeZone
utc
{-# INLINE taiEpoch #-}
taiEpoch :: AbsoluteTime
taiEpoch :: AbsoluteTime
taiEpoch = DiffTime -> AbsoluteTime
AbsoluteTime forall v. AdditiveGroup v => v
zeroV
instance AffineSpace AbsoluteTime where
type Diff AbsoluteTime = DiffTime
{-# INLINE (.-.) #-}
.-. :: AbsoluteTime -> AbsoluteTime -> Diff AbsoluteTime
(.-.) = \ (AbsoluteTime DiffTime
a) (AbsoluteTime DiffTime
b) -> DiffTime
a forall v. AdditiveGroup v => v -> v -> v
^-^ DiffTime
b
{-# INLINE (.+^) #-}
.+^ :: AbsoluteTime -> Diff AbsoluteTime -> AbsoluteTime
(.+^) = \ (AbsoluteTime DiffTime
a) Diff AbsoluteTime
d -> DiffTime -> AbsoluteTime
AbsoluteTime (DiffTime
a forall v. AdditiveGroup v => v -> v -> v
^+^ Diff AbsoluteTime
d)
data TAIUTCMap = TAIUTCMap (Map UTCTime TAIUTCRow) (Map AbsoluteTime TAIUTCRow)
deriving (INSTANCES_USUAL, Show)
data TAIUTCRow = TAIUTCRow !DiffTime !UTCTime !Rational
deriving (INSTANCES_USUAL, Show)
{-# INLINE lookupLE #-}
lookupLE :: (Ord k) => k -> Map k TAIUTCRow -> TAIUTCRow
lookupLE :: forall k. Ord k => k -> Map k TAIUTCRow -> TAIUTCRow
lookupLE k
k = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DiffTime -> UTCTime -> Rational -> TAIUTCRow
TAIUTCRow forall v. AdditiveGroup v => v
zeroV (NominalDiffTime -> UTCTime
UTCRep forall v. AdditiveGroup v => v
zeroV) Rational
0) forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupLE k
k
{-# INLINE unwrap #-}
unwrap :: TAIUTCRow -> (Micro, Micro, Rational)
unwrap :: TAIUTCRow -> (Micro, Micro, Rational)
unwrap (TAIUTCRow (DiffTime Micro
a) (UTCRep (NominalDiffTime Micro
b)) Rational
c) = (Micro
a, Micro
b, Rational
c)
{-# INLINE absoluteTime #-}
absoluteTime :: TAIUTCMap -> Iso' UTCTime AbsoluteTime
absoluteTime :: TAIUTCMap -> Iso' UTCTime AbsoluteTime
absoluteTime (TAIUTCMap Map UTCTime TAIUTCRow
utcMap Map AbsoluteTime TAIUTCRow
taiMap) = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso UTCTime -> AbsoluteTime
toTAI AbsoluteTime -> UTCTime
toUTC where
{-# INLINEABLE toTAI #-}
toTAI :: UTCTime -> AbsoluteTime
toTAI :: UTCTime -> AbsoluteTime
toTAI utime :: UTCTime
utime@(UTCRep (NominalDiffTime Micro
uts)) = DiffTime -> AbsoluteTime
AbsoluteTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. Micro -> DiffTime
DiffTime forall a b. (a -> b) -> a -> b
$
Micro
uts forall v. AdditiveGroup v => v -> v -> v
^+^ Micro
a forall v. AdditiveGroup v => v -> v -> v
^+^ (Micro
uts forall v. AdditiveGroup v => v -> v -> v
^-^ Micro
b) forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Rational
c where
(Micro
a, Micro
b, Rational
c) = TAIUTCRow -> (Micro, Micro, Rational)
unwrap forall a b. (a -> b) -> a -> b
$ forall k. Ord k => k -> Map k TAIUTCRow -> TAIUTCRow
lookupLE UTCTime
utime Map UTCTime TAIUTCRow
utcMap
{-# INLINEABLE toUTC #-}
toUTC :: AbsoluteTime -> UTCTime
toUTC :: AbsoluteTime -> UTCTime
toUTC atime :: AbsoluteTime
atime@(AbsoluteTime (DiffTime Micro
ats)) = NominalDiffTime -> UTCTime
UTCRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Micro -> NominalDiffTime
NominalDiffTime forall a b. (a -> b) -> a -> b
$
(Micro
ats forall v. AdditiveGroup v => v -> v -> v
^-^ Micro
a forall v. AdditiveGroup v => v -> v -> v
^+^ Micro
b forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Rational
c) forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ (Rational
1 forall a. Num a => a -> a -> a
+ Rational
c) where
(Micro
a, Micro
b, Rational
c) = TAIUTCRow -> (Micro, Micro, Rational)
unwrap forall a b. (a -> b) -> a -> b
$ forall k. Ord k => k -> Map k TAIUTCRow -> TAIUTCRow
lookupLE AbsoluteTime
atime Map AbsoluteTime TAIUTCRow
taiMap
{-# INLINE absoluteTime' #-}
absoluteTime' :: TAIUTCMap -> Iso' UTCView AbsoluteTime
absoluteTime' :: TAIUTCMap -> Iso' UTCView AbsoluteTime
absoluteTime' (TAIUTCMap Map UTCTime TAIUTCRow
utcMap Map AbsoluteTime TAIUTCRow
taiMap) = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso UTCView -> AbsoluteTime
toTAI AbsoluteTime -> UTCView
toUTC where
{-# INLINEABLE toTAI #-}
toTAI :: UTCView -> AbsoluteTime
toTAI :: UTCView -> AbsoluteTime
toTAI uview :: UTCView
uview@(UTCView Day
day DiffTime
_) = DiffTime -> AbsoluteTime
AbsoluteTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. Micro -> DiffTime
DiffTime forall a b. (a -> b) -> a -> b
$
Micro
uts forall v. AdditiveGroup v => v -> v -> v
^+^ Micro
a forall v. AdditiveGroup v => v -> v -> v
^+^ (Micro
uts forall v. AdditiveGroup v => v -> v -> v
^-^ Micro
b) forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Rational
c where
(Micro
a, Micro
b, Rational
c) = TAIUTCRow -> (Micro, Micro, Rational)
unwrap forall a b. (a -> b) -> a -> b
$ forall k. Ord k => k -> Map k TAIUTCRow -> TAIUTCRow
lookupLE (Iso' UTCTime UTCView
utcTime forall s t a b. AReview s t a b -> b -> t
# Day -> DiffTime -> UTCView
UTCView Day
day forall v. AdditiveGroup v => v
zeroV) Map UTCTime TAIUTCRow
utcMap
UTCRep (NominalDiffTime Micro
uts) = Iso' UTCTime UTCView
utcTime forall s t a b. AReview s t a b -> b -> t
# UTCView
uview
{-# INLINEABLE toUTC #-}
toUTC :: AbsoluteTime -> UTCView
toUTC :: AbsoluteTime -> UTCView
toUTC atime :: AbsoluteTime
atime@(AbsoluteTime (DiffTime Micro
ats)) = UTCView -> UTCView
fixup (UTCTime
utime forall s a. s -> Getting a s a -> a
^. Iso' UTCTime UTCView
utcTime) where
row :: TAIUTCRow
row@(TAIUTCRow -> (Micro, Micro, Rational)
unwrap -> (Micro
a, Micro
b, Rational
c)) = forall k. Ord k => k -> Map k TAIUTCRow -> TAIUTCRow
lookupLE AbsoluteTime
atime Map AbsoluteTime TAIUTCRow
taiMap
utime :: UTCTime
utime = NominalDiffTime -> UTCTime
UTCRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Micro -> NominalDiffTime
NominalDiffTime forall a b. (a -> b) -> a -> b
$ (Micro
ats forall v. AdditiveGroup v => v -> v -> v
^-^ Micro
a forall v. AdditiveGroup v => v -> v -> v
^+^ Micro
b forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Rational
c) forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ (Rational
1 forall a. Num a => a -> a -> a
+ Rational
c)
fixup :: UTCView -> UTCView
fixup uview :: UTCView
uview@(UTCView Day
day DiffTime
dt) = if forall k. Ord k => k -> Map k TAIUTCRow -> TAIUTCRow
lookupLE UTCTime
utime Map UTCTime TAIUTCRow
utcMap forall a. Eq a => a -> a -> Bool
== TAIUTCRow
row
then UTCView
uview else Day -> DiffTime -> UTCView
UTCView (Day
day forall p. AffineSpace p => p -> Diff p -> p
.-^ Year
1) (forall t. TimeDiff t => Rational -> t
fromSeconds' Rational
86400 forall v. AdditiveGroup v => v -> v -> v
^+^ DiffTime
dt)
utcDayLength :: TAIUTCMap -> Day -> DiffTime
utcDayLength :: TAIUTCMap -> Day -> DiffTime
utcDayLength TAIUTCMap
tum Day
day = Day -> AbsoluteTime
diff (Day
day forall p. AffineSpace p => p -> Diff p -> p
.+^ Year
1) forall p. AffineSpace p => p -> p -> Diff p
.-. Day -> AbsoluteTime
diff Day
day where
diff :: Day -> AbsoluteTime
diff Day
d = Day -> DiffTime -> UTCView
UTCView Day
d forall v. AdditiveGroup v => v
zeroV forall s a. s -> Getting a s a -> a
^. forall s t a b. AnIso s t a b -> Iso b a t s
from Iso' UTCTime UTCView
utcTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. TAIUTCMap -> Iso' UTCTime AbsoluteTime
absoluteTime TAIUTCMap
tum
parseTAIUTCRow :: P.Parser (UTCTime, TAIUTCRow)
parseTAIUTCRow :: Parser (UTCTime, TAIUTCRow)
parseTAIUTCRow = do
Year
y <- Parser ()
P.skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Integral a => Parser a
P.decimal forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"Year"
let months :: [[Char]]
months = [ [Char]
"JAN", [Char]
"FEB", [Char]
"MAR", [Char]
"APR", [Char]
"MAY", [Char]
"JUN"
, [Char]
"JUL", [Char]
"AUG", [Char]
"SEP", [Char]
"OCT", [Char]
"NOV", [Char]
"DEC" ]
Year
m <- forall a. Num a => a -> a -> a
(+) Year
1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ()
P.skipSpace forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [[Char]] -> Parser ByteString Year
indexOf [[Char]]
months forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"Month"
Year
d <- Parser ()
P.skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Integral a => Parser a
P.decimal forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"DayOfMonth"
forall {t :: * -> *}.
(Foldable t, Show (t ByteString)) =>
t ByteString -> Parser ()
tokens [ByteString
"=", ByteString
"JD"]
Year
since <- forall a. Num a => a -> a -> a
subtract Year
2400000 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Integral a => Parser a
P.decimal
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString
P.string ByteString
".5" forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"Julian Date .5"
let ymd :: YearMonthDay
ymd = Year -> Year -> Year -> YearMonthDay
YearMonthDay Year
y Year
m Year
d
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Iso' Day YearMonthDay
gregorian forall s t a b. AReview s t a b -> b -> t
# YearMonthDay
ymd forall a. Eq a => a -> a -> Bool
== Year -> Day
ModifiedJulianDay Year
since) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show YearMonthDay
ymd forall a. [a] -> [a] -> [a]
++ [Char]
" ≠ MJD " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Year
since
forall a. [a] -> [a] -> [a]
++ [Char]
" ≡ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Year -> Day
ModifiedJulianDay Year
since)
forall {t :: * -> *}.
(Foldable t, Show (t ByteString)) =>
t ByteString -> Parser ()
tokens [ByteString
"TAI", ByteString
"-", ByteString
"UTC", ByteString
"="]
Rational
a <- forall a. Fractional a => Parser a
P.rational forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"Additive"
forall {t :: * -> *}.
(Foldable t, Show (t ByteString)) =>
t ByteString -> Parser ()
tokens [ByteString
"S", ByteString
"+", ByteString
"(", ByteString
"MJD", ByteString
"-"]
Year
b <- forall a. Integral a => Parser a
P.decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
P.char Char
'.' forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"Base"
forall {t :: * -> *}.
(Foldable t, Show (t ByteString)) =>
t ByteString -> Parser ()
tokens [ByteString
")", ByteString
"X"]
Rational
c <- (forall a. Fractional a => a -> a -> a
/ forall t. TimeDiff t => t -> Rational
toSeconds' NominalDiffTime
posixDayLength) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Fractional a => Parser a
P.rational
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString
P.string ByteString
"S" forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"Coefficient"
forall (m :: * -> *) a. Monad m => a -> m a
return (Year -> UTCTime
mjdToUTC Year
since, DiffTime -> UTCTime -> Rational -> TAIUTCRow
TAIUTCRow (forall t. TimeDiff t => Rational -> t
fromSeconds' Rational
a) (Year -> UTCTime
mjdToUTC Year
b) Rational
c)
where
tokens :: t ByteString -> Parser ()
tokens t ByteString
ts = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ ByteString
tok Parser ()
a -> Parser ()
P.skipSpace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Parser ByteString
P.string ByteString
tok forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
a)
Parser ()
P.skipSpace t ByteString
ts forall i a. Parser i a -> [Char] -> Parser i a
<?> ([Char]
"tokens " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show t ByteString
ts)
mjdToUTC :: Year -> UTCTime
mjdToUTC Year
mjd = Iso' UTCTime UTCView
utcTime forall s t a b. AReview s t a b -> b -> t
# Day -> DiffTime -> UTCView
UTCView (Year -> Day
ModifiedJulianDay Year
mjd) forall v. AdditiveGroup v => v
zeroV
makeTAIUTCMap :: [(UTCTime, TAIUTCRow)] -> TAIUTCMap
makeTAIUTCMap :: [(UTCTime, TAIUTCRow)] -> TAIUTCMap
makeTAIUTCMap [(UTCTime, TAIUTCRow)]
rows = Map UTCTime TAIUTCRow -> Map AbsoluteTime TAIUTCRow -> TAIUTCMap
TAIUTCMap (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UTCTime, TAIUTCRow)]
rows)
(forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ (UTCTime, TAIUTCRow) -> (AbsoluteTime, TAIUTCRow)
invert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UTCTime, TAIUTCRow)]
rows) where
invert :: (UTCTime, TAIUTCRow) -> (AbsoluteTime, TAIUTCRow)
invert (UTCTime
since, TAIUTCRow
entry) = (UTCTime
since forall s a. s -> Getting a s a -> a
^. TAIUTCMap -> Iso' UTCTime AbsoluteTime
absoluteTime TAIUTCMap
single, TAIUTCRow
entry) where
single :: TAIUTCMap
single = Map UTCTime TAIUTCRow -> Map AbsoluteTime TAIUTCRow -> TAIUTCMap
TAIUTCMap (forall k a. k -> a -> Map k a
Map.singleton UTCTime
since TAIUTCRow
entry) forall a. Monoid a => a
mempty
parseTAIUTCDAT :: S.ByteString -> Either String TAIUTCMap
parseTAIUTCDAT :: ByteString -> Either [Char] TAIUTCMap
parseTAIUTCDAT = forall a. Parser a -> ByteString -> Either [Char] a
P.parseOnly forall a b. (a -> b) -> a -> b
$ [(UTCTime, TAIUTCRow)] -> TAIUTCMap
makeTAIUTCMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
P.manyTill
(Parser (UTCTime, TAIUTCRow)
parseTAIUTCRow forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.endOfLine) forall t. Chunk t => Parser t ()
P.endOfInput
{-# INLINE addAbsoluteTime #-}
addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime
addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime
addAbsoluteTime = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall p. AffineSpace p => p -> Diff p -> p
(.+^)
{-# INLINE diffAbsoluteTime #-}
diffAbsoluteTime :: AbsoluteTime -> AbsoluteTime -> DiffTime
diffAbsoluteTime :: AbsoluteTime -> AbsoluteTime -> DiffTime
diffAbsoluteTime = forall p. AffineSpace p => p -> p -> Diff p
(.-.)
{-# INLINE utcToTAITime #-}
utcToTAITime :: TAIUTCMap -> UTCTime -> AbsoluteTime
utcToTAITime :: TAIUTCMap -> UTCTime -> AbsoluteTime
utcToTAITime TAIUTCMap
m = forall a s. Getting a s a -> s -> a
view (TAIUTCMap -> Iso' UTCTime AbsoluteTime
absoluteTime TAIUTCMap
m)
{-# INLINE taiToUTCTime #-}
taiToUTCTime :: TAIUTCMap -> AbsoluteTime -> UTCTime
taiToUTCTime :: TAIUTCMap -> AbsoluteTime -> UTCTime
taiToUTCTime TAIUTCMap
m = forall s t a b. AReview s t a b -> b -> t
review (TAIUTCMap -> Iso' UTCTime AbsoluteTime
absoluteTime TAIUTCMap
m)