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

-- | <https://en.wikipedia.org/wiki/International_Atomic_Time International Atomic Time>
-- (TAI) and conversion to/from UTC, accounting for leap seconds.
module Data.Thyme.Clock.TAI
    ( AbsoluteTime
    , taiEpoch
    , TAIUTCMap (..)
    , TAIUTCRow (..)
    , absoluteTime
    , absoluteTime'
    , utcDayLength
    , parseTAIUTCRow
    , makeTAIUTCMap
    , parseTAIUTCDAT

    -- * Compatibility
    , 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

-- | <https://en.wikipedia.org/wiki/International_Atomic_Time Temps Atomique International>
-- (TAI). Note that for most applications 'UTCTime' is perfectly sufficient,
-- and much more convenient to use.
--
-- Internally this is the number of seconds since 'taiEpoch'. TAI days are
-- exactly 86400 SI seconds long.
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 = Year -> LocalTime -> ShowS
forall a. Show a => Year -> a -> ShowS
showsPrec Year
p LocalTime
lt ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
forall a. [a] -> [a] -> [a]
(++) [Char]
" 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 (TAIUTCMap -> Iso' UTCTime AbsoluteTime
absoluteTime (TAIUTCMap -> Iso' UTCTime AbsoluteTime)
-> TAIUTCMap -> Iso' UTCTime AbsoluteTime
forall a b. (a -> b) -> a -> b
$ Map UTCTime TAIUTCRow -> Map AbsoluteTime TAIUTCRow -> TAIUTCMap
TAIUTCMap Map UTCTime TAIUTCRow
forall a. Monoid a => a
mempty Map AbsoluteTime TAIUTCRow
forall a. Monoid a => a
mempty) 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 <http://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Day>
-- epoch, 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 DiffTime
a) (AbsoluteTime DiffTime
b) -> DiffTime
a DiffTime -> DiffTime -> DiffTime
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 DiffTime -> DiffTime -> DiffTime
forall v. AdditiveGroup v => v -> v -> v
^+^ Diff AbsoluteTime
DiffTime
d)

-- | A table of 'TAIUTCRow's for converting between TAI and UTC.
--
-- The two 'Map's are keyed on the corresponding instants in UTC and TAI
-- from which the 'TAIUTCRow' becomes applicable. The 'UTCTime' key of the
-- first 'Map' is always at midnight.
--
-- No table is provided here because leap seconds are unpredictable, and any
-- program shipped with such a table could become out-of-date in as little
-- as 6 months. See 'parseTAIUTCDAT' for details.
data TAIUTCMap = TAIUTCMap (Map UTCTime TAIUTCRow) (Map AbsoluteTime TAIUTCRow)
    deriving (INSTANCES_USUAL, Show)

-- | Each line of TAIUTCDAT (see 'parseTAIUTCDAT') specifies the difference
-- between TAI and UTC for a particular period. For example:
--
-- @
-- 1968 FEB  1 =JD 2439887.5  TAI-UTC=   4.2131700 S + (MJD - 39126.) X 0.002592 S
-- @
--
-- says that from 1968-02-01 00:00:00 (Julian Date 2439887.5; or Modified
-- Julian Date 39887.0), the difference between TAI and UTC is @4.2131700s@
-- (the /additive/ part) plus a scaled component that increases for each day
-- beyond MJD 39126 (the /base/) by 0.002592s (the /coefficient/). In
-- general, the latter half of each line is of the form:
--
-- @
-- TAI-UTC= /additive/ S + (MJD - /base/) X /coefficient/ S
-- @
--
-- @'TAIUTCRow' a b c@ is a normalised version of the above, with the /base/
-- multiplied by 86400s, and the /coefficient/ divided by the same. This
-- allows us to use the internal representation of 'UTCTime'—seconds since
-- the MJD epoch—as the @MJD@ term without further rescaling.
--
-- Note that between 1961-01-01 and 1972-01-01, each UTC second was actually
-- slightly longer than one TAI (or SI) second. For the first year this was
-- at the rate of exactly 1.000000015 TAI (or SI) seconds per UTC second,
-- but was subject to irregular updates. Since leap seconds came into effect
-- on 1972-01-01, the /additive/ part has always been an intergral number of
-- seconds, and the /coefficient/ has always been zero.
--
-- To convert between TAI and UTC, we refer to the definition:
--
-- @
-- TAI - UTC = a + (MJD - b) * c
-- @
--
-- Using UTC for MJD (with 'b' and 'c' scaled as described above):
--
-- @
-- TAI = UTC + a + (UTC - b) * c
-- TAI - a + b * c = UTC + UTC * c
-- (TAI - a + b * c) / (1 + c) = UTC
-- @
--
-- This is implemented by 'absoluteTime' and 'absoluteTime''.
--
-- Further reading:
--
-- * https://en.wikipedia.org/wiki/Coordinated_Universal_Time
-- * https://en.wikipedia.org/wiki/International_Atomic_Time
data TAIUTCRow = TAIUTCRow !DiffTime !UTCTime !Rational
    -- ^ Each row comprises of an /additive/ component, the /base/ of the
    -- scaled component, and the /coefficient/ of the scaled component.
    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 = TAIUTCRow
-> ((k, TAIUTCRow) -> TAIUTCRow)
-> Maybe (k, TAIUTCRow)
-> TAIUTCRow
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DiffTime -> UTCTime -> Rational -> TAIUTCRow
TAIUTCRow DiffTime
forall v. AdditiveGroup v => v
zeroV (NominalDiffTime -> UTCTime
UTCRep NominalDiffTime
forall v. AdditiveGroup v => v
zeroV) Rational
0) (k, TAIUTCRow) -> TAIUTCRow
forall a b. (a, b) -> b
snd (Maybe (k, TAIUTCRow) -> TAIUTCRow)
-> (Map k TAIUTCRow -> Maybe (k, TAIUTCRow))
-> Map k TAIUTCRow
-> TAIUTCRow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> Map k TAIUTCRow -> Maybe (k, TAIUTCRow)
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)

-- | Convert between 'UTCTime' and 'AbsoluteTime' using a 'TAIUTCMap'.
--
-- Since 'UTCTime' cannot represent a time-of-day of 86400s or more, any
-- conversion from 'AbsoluteTime' that happens to be during a leap second
-- will overflow into the next day.
--
-- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below.
--
-- @
-- > let jul1 = 'utcTime' 'Control.Lens.#' 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 7 1) 'zeroV'
-- > jul1 '&' 'absoluteTime' tum '%~' ('.-^' 'fromSeconds' 1.1)
-- 2015-06-30 23:59:59.9 UTC
-- @
{-# INLINE absoluteTime #-}
absoluteTime :: TAIUTCMap -> Iso' UTCTime AbsoluteTime
absoluteTime :: TAIUTCMap -> Iso' UTCTime AbsoluteTime
absoluteTime (TAIUTCMap Map UTCTime TAIUTCRow
utcMap Map AbsoluteTime TAIUTCRow
taiMap) = (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
toUTC where
    {-# INLINEABLE toTAI #-}
    toTAI :: UTCTime -> AbsoluteTime
    toTAI :: UTCTime -> AbsoluteTime
toTAI utime :: UTCTime
utime@(UTCRep (NominalDiffTime Micro
uts)) = DiffTime -> AbsoluteTime
AbsoluteTime (DiffTime -> AbsoluteTime)
-> (Micro -> DiffTime) -> Micro -> AbsoluteTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Micro -> DiffTime
DiffTime (Micro -> AbsoluteTime) -> Micro -> AbsoluteTime
forall a b. (a -> b) -> a -> b
$
            Micro
uts Micro -> Micro -> Micro
forall v. AdditiveGroup v => v -> v -> v
^+^ Micro
a Micro -> Micro -> Micro
forall v. AdditiveGroup v => v -> v -> v
^+^ (Micro
uts Micro -> Micro -> Micro
forall v. AdditiveGroup v => v -> v -> v
^-^ Micro
b) Micro -> Rational -> Micro
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 (TAIUTCRow -> (Micro, Micro, Rational))
-> TAIUTCRow -> (Micro, Micro, Rational)
forall a b. (a -> b) -> a -> b
$ UTCTime -> Map UTCTime TAIUTCRow -> TAIUTCRow
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 (NominalDiffTime -> UTCTime)
-> (Micro -> NominalDiffTime) -> Micro -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Micro -> NominalDiffTime
NominalDiffTime (Micro -> UTCTime) -> Micro -> UTCTime
forall a b. (a -> b) -> a -> b
$
            (Micro
ats Micro -> Micro -> Micro
forall v. AdditiveGroup v => v -> v -> v
^-^ Micro
a Micro -> Micro -> Micro
forall v. AdditiveGroup v => v -> v -> v
^+^ Micro
b Micro -> Rational -> Micro
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Rational
c) Micro -> Rational -> Micro
forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ (Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
c) where
        (Micro
a, Micro
b, Rational
c) = TAIUTCRow -> (Micro, Micro, Rational)
unwrap (TAIUTCRow -> (Micro, Micro, Rational))
-> TAIUTCRow -> (Micro, Micro, Rational)
forall a b. (a -> b) -> a -> b
$ AbsoluteTime -> Map AbsoluteTime TAIUTCRow -> TAIUTCRow
forall k. Ord k => k -> Map k TAIUTCRow -> TAIUTCRow
lookupLE AbsoluteTime
atime Map AbsoluteTime TAIUTCRow
taiMap

-- | Convert between 'UTCView' and TAI 'AbsoluteTime' using a 'TAIUTCMap'.
--
-- Unlike 'absoluteTime', 'UTCView' /can/ represent a time-of-day greater
-- than 86400s, and this gives the correct results during a leap second.
--
-- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below.
--
-- @
-- > let jul1 = 'UTCView' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 7 1) 'zeroV'
-- > jul1 '&' 'absoluteTime'' tum '%~' ('.-^' 'fromSeconds' 0.1)
-- 'UTCView' {'utcvDay' = 2015-06-30, 'utcvDayTime' = 86400.9s}
-- @
--
-- However keep in mind that currently there is no standard way to get the
-- TAI on most platforms. Simply converting the result of
-- 'Data.Thyme.Clock.getCurrentTime' (which calls @gettimeofday(2)@) to
-- 'AbsoluteTime' during a leap second will still give non-monotonic times.
{-# INLINE absoluteTime' #-}
absoluteTime' :: TAIUTCMap -> Iso' UTCView AbsoluteTime
absoluteTime' :: TAIUTCMap -> Iso' UTCView AbsoluteTime
absoluteTime' (TAIUTCMap Map UTCTime TAIUTCRow
utcMap Map AbsoluteTime TAIUTCRow
taiMap) = (UTCView -> AbsoluteTime)
-> (AbsoluteTime -> UTCView) -> Iso' UTCView AbsoluteTime
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 (DiffTime -> AbsoluteTime)
-> (Micro -> DiffTime) -> Micro -> AbsoluteTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Micro -> DiffTime
DiffTime (Micro -> AbsoluteTime) -> Micro -> AbsoluteTime
forall a b. (a -> b) -> a -> b
$
            Micro
uts Micro -> Micro -> Micro
forall v. AdditiveGroup v => v -> v -> v
^+^ Micro
a Micro -> Micro -> Micro
forall v. AdditiveGroup v => v -> v -> v
^+^ (Micro
uts Micro -> Micro -> Micro
forall v. AdditiveGroup v => v -> v -> v
^-^ Micro
b) Micro -> Rational -> Micro
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 (TAIUTCRow -> (Micro, Micro, Rational))
-> TAIUTCRow -> (Micro, Micro, Rational)
forall a b. (a -> b) -> a -> b
$ UTCTime -> Map UTCTime TAIUTCRow -> TAIUTCRow
forall k. Ord k => k -> Map k TAIUTCRow -> TAIUTCRow
lookupLE (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
UTCView Day
day DiffTime
forall v. AdditiveGroup v => v
zeroV) Map UTCTime TAIUTCRow
utcMap
        UTCRep (NominalDiffTime Micro
uts) = 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
# UTCView
uview

    {-# INLINEABLE toUTC #-}
    toUTC :: AbsoluteTime -> UTCView
    toUTC :: AbsoluteTime -> UTCView
toUTC atime :: AbsoluteTime
atime@(AbsoluteTime (DiffTime Micro
ats)) = UTCView -> UTCView
fixup (UTCTime
utime UTCTime -> Getting UTCView UTCTime UTCView -> UTCView
forall s a. s -> Getting a s a -> a
^. Getting UTCView UTCTime UTCView
Iso' UTCTime UTCView
utcTime) where
        row :: TAIUTCRow
row@(TAIUTCRow -> (Micro, Micro, Rational)
unwrap -> (Micro
a, Micro
b, Rational
c)) = AbsoluteTime -> Map AbsoluteTime TAIUTCRow -> TAIUTCRow
forall k. Ord k => k -> Map k TAIUTCRow -> TAIUTCRow
lookupLE AbsoluteTime
atime Map AbsoluteTime TAIUTCRow
taiMap
        utime :: UTCTime
utime = NominalDiffTime -> UTCTime
UTCRep (NominalDiffTime -> UTCTime)
-> (Micro -> NominalDiffTime) -> Micro -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Micro -> NominalDiffTime
NominalDiffTime (Micro -> UTCTime) -> Micro -> UTCTime
forall a b. (a -> b) -> a -> b
$ (Micro
ats Micro -> Micro -> Micro
forall v. AdditiveGroup v => v -> v -> v
^-^ Micro
a Micro -> Micro -> Micro
forall v. AdditiveGroup v => v -> v -> v
^+^ Micro
b Micro -> Rational -> Micro
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Rational
c) Micro -> Rational -> Micro
forall v s.
(VectorSpace v, s ~ Scalar v, Fractional s) =>
v -> s -> v
^/ (Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
c)
        -- 'lookupLE' of the same instant in 'utcMap' and 'taiMap' should
        -- give the same 'TAIUTCRow'. If it doesn't, then @utime@ must have
        -- overflown into the next 'Day'.
        fixup :: UTCView -> UTCView
fixup uview :: UTCView
uview@(UTCView Day
day DiffTime
dt) = if UTCTime -> Map UTCTime TAIUTCRow -> TAIUTCRow
forall k. Ord k => k -> Map k TAIUTCRow -> TAIUTCRow
lookupLE UTCTime
utime Map UTCTime TAIUTCRow
utcMap TAIUTCRow -> TAIUTCRow -> Bool
forall a. Eq a => a -> a -> Bool
== TAIUTCRow
row
            then UTCView
uview else Day -> DiffTime -> UTCView
UTCView (Day
day Day -> Diff Day -> Day
forall p. AffineSpace p => p -> Diff p -> p
.-^ Year
Diff Day
1) (Rational -> DiffTime
forall t. TimeDiff t => Rational -> t
fromSeconds' Rational
86400 DiffTime -> DiffTime -> DiffTime
forall v. AdditiveGroup v => v -> v -> v
^+^ DiffTime
dt)

-- TODO: Linux >= 3.10 has @CLOCK_TAI@ for @clock_gettime(2)@.

-- | Using a 'TAIUTCMap', lookup the 'DiffTime' length of the UTC 'Day'.
--
-- See 'parseTAIUTCDAT' for how to obtain the @tum :: 'TAIUTCMap'@ below.
--
-- @
-- > 'utcDayLength' tum '.' 'view' '_utctDay' '<$>' 'getCurrentTime'
-- 86400s
-- > 'utcDayLength' tum '$' 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 6 30
-- 86401s
-- @
utcDayLength :: TAIUTCMap -> Day -> DiffTime
utcDayLength :: TAIUTCMap -> Day -> DiffTime
utcDayLength TAIUTCMap
tum Day
day = Day -> AbsoluteTime
diff (Day
day Day -> Diff Day -> Day
forall p. AffineSpace p => p -> Diff p -> p
.+^ Year
Diff Day
1) AbsoluteTime -> AbsoluteTime -> Diff AbsoluteTime
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 DiffTime
forall v. AdditiveGroup v => v
zeroV UTCView
-> Getting AbsoluteTime UTCView AbsoluteTime -> AbsoluteTime
forall s a. s -> Getting a s a -> a
^. AnIso UTCTime UTCTime UTCView UTCView
-> Iso UTCView UTCView UTCTime UTCTime
forall s t a b. AnIso s t a b -> Iso b a t s
from AnIso UTCTime UTCTime UTCView UTCView
Iso' UTCTime UTCView
utcTime Overloaded
  (->) (Const AbsoluteTime) UTCView UTCView UTCTime UTCTime
-> ((AbsoluteTime -> Const AbsoluteTime AbsoluteTime)
    -> UTCTime -> Const AbsoluteTime UTCTime)
-> Getting AbsoluteTime UTCView AbsoluteTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TAIUTCMap -> Iso' UTCTime AbsoluteTime
absoluteTime TAIUTCMap
tum

-- | @attoparsec@ 'P.Parser' for a single line of TAIUTCDAT.
--
-- Returns the starting 'UTCTime' and the normalised 'TAIUTCRow'.
parseTAIUTCRow :: P.Parser (UTCTime, TAIUTCRow)
parseTAIUTCRow :: Parser (UTCTime, TAIUTCRow)
parseTAIUTCRow = do
    Year
y <- Parser ()
P.skipSpace Parser () -> Parser ByteString Year -> Parser ByteString Year
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Year
forall a. Integral a => Parser a
P.decimal Parser ByteString Year -> [Char] -> Parser ByteString Year
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 <- Year -> Year -> Year
forall a. Num a => a -> a -> a
(+) Year
1 (Year -> Year) -> Parser () -> Parser ByteString (Year -> Year)
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ()
P.skipSpace Parser ByteString (Year -> Year)
-> Parser ByteString Year -> Parser ByteString Year
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [[Char]] -> Parser ByteString Year
indexOf [[Char]]
months Parser ByteString Year -> [Char] -> Parser ByteString Year
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"Month"
    Year
d <- Parser ()
P.skipSpace Parser () -> Parser ByteString Year -> Parser ByteString Year
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Year
forall a. Integral a => Parser a
P.decimal Parser ByteString Year -> [Char] -> Parser ByteString Year
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"DayOfMonth"

    [ByteString] -> Parser ()
forall {t :: * -> *}.
(Foldable t, Show (t ByteString)) =>
t ByteString -> Parser ()
tokens [ByteString
"=", ByteString
"JD"]
    -- TAI-UTC changes always happen at midnight UTC, so just ignore ".5".
    Year
since <- Year -> Year -> Year
forall a. Num a => a -> a -> a
subtract Year
2400000{-.5-} (Year -> Year) -> Parser ByteString Year -> Parser ByteString Year
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Year
forall a. Integral a => Parser a
P.decimal
        Parser ByteString Year
-> Parser ByteString ByteString -> Parser ByteString Year
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString ByteString
P.string ByteString
".5" Parser ByteString Year -> [Char] -> Parser ByteString Year
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
    Bool -> Parser () -> Parser ()
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
== Year -> Day
ModifiedJulianDay Year
since) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> Parser ()
forall a. [Char] -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser ()) -> [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ YearMonthDay -> [Char]
forall a. Show a => a -> [Char]
show YearMonthDay
ymd [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" ≠ MJD " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Year -> [Char]
forall a. Show a => a -> [Char]
show Year
since
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" ≡ " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Day -> [Char]
forall a. Show a => a -> [Char]
show (Year -> Day
ModifiedJulianDay Year
since)

    [ByteString] -> Parser ()
forall {t :: * -> *}.
(Foldable t, Show (t ByteString)) =>
t ByteString -> Parser ()
tokens [ByteString
"TAI", ByteString
"-", ByteString
"UTC", ByteString
"="]
    Rational
a <- Parser Rational
forall a. Fractional a => Parser a
P.rational Parser Rational -> [Char] -> Parser Rational
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"Additive"
    [ByteString] -> Parser ()
forall {t :: * -> *}.
(Foldable t, Show (t ByteString)) =>
t ByteString -> Parser ()
tokens [ByteString
"S", ByteString
"+", ByteString
"(", ByteString
"MJD", ByteString
"-"]
    Year
b <- Parser ByteString Year
forall a. Integral a => Parser a
P.decimal Parser ByteString Year
-> Parser ByteString Char -> Parser ByteString Year
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
P.char Char
'.' Parser ByteString Year -> [Char] -> Parser ByteString Year
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"Base" -- also always midnight UTC
    [ByteString] -> Parser ()
forall {t :: * -> *}.
(Foldable t, Show (t ByteString)) =>
t ByteString -> Parser ()
tokens [ByteString
")", ByteString
"X"]
    Rational
c <- (Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ NominalDiffTime -> Rational
forall t. TimeDiff t => t -> Rational
toSeconds' NominalDiffTime
posixDayLength) (Rational -> Rational) -> Parser Rational -> Parser Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Rational
forall a. Fractional a => Parser a
P.rational
        Parser Rational -> Parser () -> Parser Rational
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.skipSpace Parser Rational -> Parser ByteString ByteString -> Parser Rational
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString ByteString
P.string ByteString
"S" Parser Rational -> [Char] -> Parser Rational
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"Coefficient"

    (UTCTime, TAIUTCRow) -> Parser (UTCTime, TAIUTCRow)
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Year -> UTCTime
mjdToUTC Year
since, DiffTime -> UTCTime -> Rational -> TAIUTCRow
TAIUTCRow (Rational -> DiffTime
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 = (ByteString -> Parser () -> Parser ())
-> Parser () -> t ByteString -> Parser ()
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ ByteString
tok Parser ()
a -> Parser ()
P.skipSpace Parser ()
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Parser ByteString ByteString
P.string ByteString
tok Parser ByteString ByteString -> Parser () -> Parser ()
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
a)
        Parser ()
P.skipSpace t ByteString
ts Parser () -> [Char] -> Parser ()
forall i a. Parser i a -> [Char] -> Parser i a
<?> ([Char]
"tokens " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ t ByteString -> [Char]
forall a. Show a => a -> [Char]
show t ByteString
ts)
    mjdToUTC :: Year -> UTCTime
mjdToUTC Year
mjd = 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
UTCView (Year -> Day
ModifiedJulianDay Year
mjd) DiffTime
forall v. AdditiveGroup v => v
zeroV

-- | Build a 'TAIUTCMap' from the result of 'parseTAIUTCRow'.
makeTAIUTCMap :: [(UTCTime, TAIUTCRow)] -> TAIUTCMap
makeTAIUTCMap :: [(UTCTime, TAIUTCRow)] -> TAIUTCMap
makeTAIUTCMap [(UTCTime, TAIUTCRow)]
rows = Map UTCTime TAIUTCRow -> Map AbsoluteTime TAIUTCRow -> TAIUTCMap
TAIUTCMap ([(UTCTime, TAIUTCRow)] -> Map UTCTime TAIUTCRow
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UTCTime, TAIUTCRow)]
rows)
        ([(AbsoluteTime, TAIUTCRow)] -> Map AbsoluteTime TAIUTCRow
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(AbsoluteTime, TAIUTCRow)] -> Map AbsoluteTime TAIUTCRow)
-> [(AbsoluteTime, TAIUTCRow)] -> Map AbsoluteTime TAIUTCRow
forall a b. (a -> b) -> a -> b
$ (UTCTime, TAIUTCRow) -> (AbsoluteTime, TAIUTCRow)
invert ((UTCTime, TAIUTCRow) -> (AbsoluteTime, TAIUTCRow))
-> [(UTCTime, TAIUTCRow)] -> [(AbsoluteTime, TAIUTCRow)]
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 UTCTime
-> ((AbsoluteTime -> Const AbsoluteTime AbsoluteTime)
    -> UTCTime -> Const AbsoluteTime UTCTime)
-> AbsoluteTime
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 (UTCTime -> TAIUTCRow -> Map UTCTime TAIUTCRow
forall k a. k -> a -> Map k a
Map.singleton UTCTime
since TAIUTCRow
entry) Map AbsoluteTime TAIUTCRow
forall a. Monoid a => a
mempty

-- | Parse the contents of TAIUTCDAT into a 'TAIUTCMap' for conversion
-- between TAI and UTC.
--
-- @
-- $ curl -O \"http:\/\/maia.usno.navy.mil\/ser7\/tai-utc.dat\"
-- $ ghci --package thyme
-- > import "Data.Thyme"
-- > import "Data.Thyme.Clock.TAI"
-- > import "Data.ByteString" ('S.readFile')
-- > Right tum \<- 'parseTAIUTCDAT' '<$>' 'S.readFile' \"tai-utc.dat\"
-- > 'utcDayLength' tum '$' 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2015 6 30
-- 86401s
-- @
parseTAIUTCDAT :: S.ByteString -> Either String TAIUTCMap
parseTAIUTCDAT :: ByteString -> Either [Char] TAIUTCMap
parseTAIUTCDAT = Parser TAIUTCMap -> ByteString -> Either [Char] TAIUTCMap
forall a. Parser a -> ByteString -> Either [Char] a
P.parseOnly (Parser TAIUTCMap -> ByteString -> Either [Char] TAIUTCMap)
-> Parser TAIUTCMap -> ByteString -> Either [Char] TAIUTCMap
forall a b. (a -> b) -> a -> b
$ [(UTCTime, TAIUTCRow)] -> TAIUTCMap
makeTAIUTCMap ([(UTCTime, TAIUTCRow)] -> TAIUTCMap)
-> Parser ByteString [(UTCTime, TAIUTCRow)] -> Parser TAIUTCMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (UTCTime, TAIUTCRow)
-> Parser () -> Parser ByteString [(UTCTime, TAIUTCRow)]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
P.manyTill
    (Parser (UTCTime, TAIUTCRow)
parseTAIUTCRow Parser (UTCTime, TAIUTCRow)
-> Parser () -> Parser (UTCTime, TAIUTCRow)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
P.endOfLine) Parser ()
forall t. Chunk t => Parser t ()
P.endOfInput

------------------------------------------------------------------------

-- | Add a duration to an 'AbsoluteTime'.
--
-- @
-- 'addAbsoluteTime' = 'flip' ('.+^')
-- 'addAbsoluteTime' d t ≡ t '.+^' d
-- @
--
-- See also the 'AffineSpace' instance for 'AbsoluteTime'.
{-# INLINE addAbsoluteTime #-}
addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime
addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime
addAbsoluteTime = (AbsoluteTime -> DiffTime -> AbsoluteTime)
-> DiffTime -> AbsoluteTime -> AbsoluteTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip AbsoluteTime -> Diff AbsoluteTime -> AbsoluteTime
AbsoluteTime -> DiffTime -> AbsoluteTime
forall p. AffineSpace p => p -> Diff p -> p
(.+^)

-- | The duration difference between two 'AbsoluteTime's.
--
-- @
-- 'diffAbsoluteTime' = ('.-.')
-- 'diffAbsoluteTime' a b ≡ a '.-.' b
-- @
--
-- See also the 'AffineSpace' instance for 'AbsoluteTime'.
{-# INLINE diffAbsoluteTime #-}
diffAbsoluteTime :: AbsoluteTime -> AbsoluteTime -> DiffTime
diffAbsoluteTime :: AbsoluteTime -> AbsoluteTime -> DiffTime
diffAbsoluteTime = AbsoluteTime -> AbsoluteTime -> Diff AbsoluteTime
AbsoluteTime -> AbsoluteTime -> DiffTime
forall p. AffineSpace p => p -> p -> Diff p
(.-.)

-- | Using a 'TAIUTCMap', convert a 'UTCTime' to 'AbsoluteTime'.
--
-- @
-- 'utcToTAITime' = 'view' '.' 'absoluteTime'
-- @
{-# INLINE utcToTAITime #-}
utcToTAITime :: TAIUTCMap -> UTCTime -> AbsoluteTime
utcToTAITime :: TAIUTCMap -> UTCTime -> AbsoluteTime
utcToTAITime TAIUTCMap
m = ((AbsoluteTime -> Const AbsoluteTime AbsoluteTime)
 -> UTCTime -> Const AbsoluteTime UTCTime)
-> UTCTime -> AbsoluteTime
forall a s. Getting a s a -> s -> a
view (TAIUTCMap -> Iso' UTCTime AbsoluteTime
absoluteTime TAIUTCMap
m)

-- | Using a 'TAIUTCMap', convert a 'AbsoluteTime' to 'UTCTime'.
--
-- @
-- 'taiToUTCTime' = 'review' '.' 'absoluteTime'
-- @
{-# INLINE taiToUTCTime #-}
taiToUTCTime :: TAIUTCMap -> AbsoluteTime -> UTCTime
taiToUTCTime :: TAIUTCMap -> AbsoluteTime -> UTCTime
taiToUTCTime TAIUTCMap
m = AReview UTCTime UTCTime AbsoluteTime AbsoluteTime
-> AbsoluteTime -> UTCTime
forall s t a b. AReview s t a b -> b -> t
review (TAIUTCMap -> Iso' UTCTime AbsoluteTime
absoluteTime TAIUTCMap
m)