<commit_before>{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

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 (Parser, (<?>))
import qualified Data.Attoparsec.ByteString.Char8 as P
import Data.Basis
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.Micro
import Data.Thyme.Calendar
import Data.Thyme.Clock.Internal
import Data.Thyme.Format.Internal
import Data.Thyme.LocalTime
import Data.VectorSpace
import System.Locale

newtype AbsoluteTime = AbsoluteTime DiffTime
    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup)

instance Show AbsoluteTime where
    {-# INLINEABLE showsPrec #-}
    showsPrec p tai = showsPrec p lt . (++) " TAI" where
        lt = tai ^. from (absoluteTime (const zeroV)) . utcLocalTime utc

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

instance AffineSpace AbsoluteTime where
    type Diff AbsoluteTime = DiffTime
    {-# INLINE (.-.) #-}
    AbsoluteTime a .-. AbsoluteTime b = a ^-^ b
    {-# INLINE (.+^) #-}
    AbsoluteTime a .+^ d = AbsoluteTime (a ^+^ d)

type LeapSecondTable = Either UTCTime AbsoluteTime -> DiffTime

utcDayLength :: LeapSecondTable -> Day -> DiffTime
utcDayLength table day@((.+^ 1) -> next) =
        DiffTime posixDay ^+^ diff next ^-^ diff day where
    diff d = table . Left $ review utcTime (UTCTime d zeroV)
    NominalDiffTime posixDay = posixDayLength

{-# INLINE absoluteTime #-}
absoluteTime :: LeapSecondTable -> Iso' UTCTime AbsoluteTime
absoluteTime table = iso toTAI fromTAI where

    {-# INLINE toTAI #-}
    toTAI :: UTCTime -> AbsoluteTime
    toTAI ut@(UTCRep (NominalDiffTime u)) =
        AbsoluteTime (DiffTime u ^+^ table (Left ut))

    {-# INLINE fromTAI #-}
    fromTAI :: AbsoluteTime -> UTCTime
    fromTAI tai@(AbsoluteTime a) = UTCRep (NominalDiffTime u) where
        DiffTime u = a ^-^ table (Right tai)

-- | @tai-utc.dat@ from <http://maia.usno.navy.mil/ser7/tai-utc.dat>
{-# INLINEABLE parseTAIUTCDAT #-}
parseTAIUTCDAT :: ByteString -> LeapSecondTable
parseTAIUTCDAT = parse $ do
    y <- dec_ 5 <* P.skipSpace <?> "Year"
    let mons = map toUpper . snd <$> months defaultTimeLocale
    m <- succ <$> indexOf mons <* P.skipSpace <?> "Month"
    d <- dec_ 2 <?> "Day"
    tokens ["=", "JD"]
    -- TAI-UTC changes always happen at midnight, so just ignore ".5".
    mjd <- subtract 2400000{-.5-} <$> P.decimal
        <* P.string ".5" <?> "Julian Date .5"
    let ymd = YearMonthDay y m d
    unless (review gregorian ymd == ModifiedJulianDay mjd) . fail $
        show ymd ++ " is not Modified Julian Day " ++ show mjd

    tokens ["TAI", "-", "UTC", "="]
    b <- micro <?> "Base"
    tokens ["S", "+", "(", "MJD", "-"]
    o <- P.rational <?> "Offset"
    tokens [".", ")", "X"]
    c <- P.rational <* tokens ["S"] <?> "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 (UTCRep (NominalDiffTime t)) = DiffTime $
            b ^+^ (c * (t ^/^ posixDay - o)) *^ basisValue ()
    let c1' = recip (1 + c); c1'c = c1' * c
    -- TAI-UTC = (b + c * (MJD(TAI) - o)) / (1 + c)
    let atTAI (AbsoluteTime (DiffTime t)) = DiffTime $
            c1' *^ b ^+^ (c1'c * (t ^/^ posixDay - o)) *^ basisValue ()
    let begin = toRational mjd *^ posixDay
    let beginUTC = UTCRep (NominalDiffTime begin)
    let beginTAI = AbsoluteTime (DiffTime begin ^-^ atUTC beginUTC)
    return ((beginUTC, atUTC), (beginTAI, atTAI))

  where
    NominalDiffTime posixDay = posixDayLength
    tokens = foldr (\ tok a -> P.skipSpace >> P.string tok >> a) P.skipSpace

    parse row = pair . unzip . rights . map (P.parseOnly row) . S.lines
    pair (look -> atUTC, look -> atTAI) = either atUTC atTAI
#if MIN_VERSION_containers(0,5,0)
    look l = \ t -> maybe zeroV (($ t) . snd) $ Map.lookupLE t (Map.fromList l)
#else
    look l = \ t -> case Map.splitLookup t (Map.fromList l) of
        (lt, eq, _) -> maybe zeroV ($ t) $ eq <|> fst <$> Map.maxView lt
#endif

    {-# INLINEABLE micro #-}
    micro :: Parser Micro
    micro = do
        s <- P.decimal <* P.string "."
        us10 <- either fail return . P.parseOnly P.decimal . S.take 7
            . (`S.append` S.pack "000000") =<< P.takeWhile1 P.isDigit
        return $ Micro (s * 1000000 + div (us10 + 5) 10)
<commit_msg>Data.Thyme.Clock.TAI: parse '-' sign in micro ∷ Parser Micro<commit_after>{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

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 (Parser, (<?>))
import qualified Data.Attoparsec.ByteString.Char8 as P
import Data.Basis
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.Micro
import Data.Thyme.Calendar
import Data.Thyme.Clock.Internal
import Data.Thyme.Format.Internal
import Data.Thyme.LocalTime
import Data.VectorSpace
import System.Locale

newtype AbsoluteTime = AbsoluteTime DiffTime
    deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup)

instance Show AbsoluteTime where
    {-# INLINEABLE showsPrec #-}
    showsPrec p tai = showsPrec p lt . (++) " TAI" where
        lt = tai ^. from (absoluteTime (const zeroV)) . utcLocalTime utc

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

instance AffineSpace AbsoluteTime where
    type Diff AbsoluteTime = DiffTime
    {-# INLINE (.-.) #-}
    AbsoluteTime a .-. AbsoluteTime b = a ^-^ b
    {-# INLINE (.+^) #-}
    AbsoluteTime a .+^ d = AbsoluteTime (a ^+^ d)

type LeapSecondTable = Either UTCTime AbsoluteTime -> DiffTime

utcDayLength :: LeapSecondTable -> Day -> DiffTime
utcDayLength table day@((.+^ 1) -> next) =
        DiffTime posixDay ^+^ diff next ^-^ diff day where
    diff d = table . Left $ review utcTime (UTCTime d zeroV)
    NominalDiffTime posixDay = posixDayLength

{-# INLINE absoluteTime #-}
absoluteTime :: LeapSecondTable -> Iso' UTCTime AbsoluteTime
absoluteTime table = iso toTAI fromTAI where

    {-# INLINE toTAI #-}
    toTAI :: UTCTime -> AbsoluteTime
    toTAI ut@(UTCRep (NominalDiffTime u)) =
        AbsoluteTime (DiffTime u ^+^ table (Left ut))

    {-# INLINE fromTAI #-}
    fromTAI :: AbsoluteTime -> UTCTime
    fromTAI tai@(AbsoluteTime a) = UTCRep (NominalDiffTime u) where
        DiffTime u = a ^-^ table (Right tai)

-- | @tai-utc.dat@ from <http://maia.usno.navy.mil/ser7/tai-utc.dat>
{-# INLINEABLE parseTAIUTCDAT #-}
parseTAIUTCDAT :: ByteString -> LeapSecondTable
parseTAIUTCDAT = parse $ do
    y <- dec_ 5 <* P.skipSpace <?> "Year"
    let mons = map toUpper . snd <$> months defaultTimeLocale
    m <- succ <$> indexOf mons <* P.skipSpace <?> "Month"
    d <- dec_ 2 <?> "Day"
    tokens ["=", "JD"]
    -- TAI-UTC changes always happen at midnight, so just ignore ".5".
    mjd <- subtract 2400000{-.5-} <$> P.decimal
        <* P.string ".5" <?> "Julian Date .5"
    let ymd = YearMonthDay y m d
    unless (review gregorian ymd == ModifiedJulianDay mjd) . fail $
        show ymd ++ " is not Modified Julian Day " ++ show mjd

    tokens ["TAI", "-", "UTC", "="]
    b <- micro <?> "Base"
    tokens ["S", "+", "(", "MJD", "-"]
    o <- P.rational <?> "Offset"
    tokens [".", ")", "X"]
    c <- P.rational <* tokens ["S"] <?> "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 (UTCRep (NominalDiffTime t)) = DiffTime $
            b ^+^ (c * (t ^/^ posixDay - o)) *^ basisValue ()
    let c1' = recip (1 + c); c1'c = c1' * c
    -- TAI-UTC = (b + c * (MJD(TAI) - o)) / (1 + c)
    let atTAI (AbsoluteTime (DiffTime t)) = DiffTime $
            c1' *^ b ^+^ (c1'c * (t ^/^ posixDay - o)) *^ basisValue ()
    let begin = toRational mjd *^ posixDay
    let beginUTC = UTCRep (NominalDiffTime begin)
    let beginTAI = AbsoluteTime (DiffTime begin ^-^ atUTC beginUTC)
    return ((beginUTC, atUTC), (beginTAI, atTAI))

  where
    NominalDiffTime posixDay = posixDayLength
    tokens = foldr (\ tok a -> P.skipSpace >> P.string tok >> a) P.skipSpace

    parse row = pair . unzip . rights . map (P.parseOnly row) . S.lines
    pair (look -> atUTC, look -> atTAI) = either atUTC atTAI
#if MIN_VERSION_containers(0,5,0)
    look l = \ t -> maybe zeroV (($ t) . snd) $ Map.lookupLE t (Map.fromList l)
#else
    look l = \ t -> case Map.splitLookup t (Map.fromList l) of
        (lt, eq, _) -> maybe zeroV ($ t) $ eq <|> fst <$> Map.maxView lt
#endif

    {-# INLINEABLE micro #-}
    micro :: Parser Micro
    micro = do
        sign <- negate <$ P.char '-' <|> pure id
        s <- P.decimal <* P.char '.'
        us10 <- either fail return . P.parseOnly P.decimal . S.take 7
            . (`S.append` S.pack "000000") =<< P.takeWhile1 P.isDigit
        return . Micro . sign $ s * 1000000 + div (us10 + 5) 10

{'fraction_non_alphanumeric': 0.14266211604095563, 'fraction_numerical': 0.014041930765480253, 'mean_word_length': 2.899619771863118, 'pattern_counts': {'":': 0, '<': 66, '<?xml version=': 0, '>': 68, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5188079', 'n_tokens_mistral': 3881, 'n_tokens_neox': 3633, 'n_words': 1041}