{-# OPTIONS -fno-warn-unused-imports #-}
#include "HsConfigure.h"
-- | TAI and leap-second tables for converting to UTC: most people won't need this module.
module Data.Time.Clock.TAI
(
    -- TAI arithmetic
    AbsoluteTime,taiEpoch,addAbsoluteTime,diffAbsoluteTime,

    -- leap-second table type
    LeapSecondTable,

    -- conversion between UTC and TAI with table
    utcDayLength,utcToTAITime,taiToUTCTime,

    parseTAIUTCDATFile
) where

import Data.Time.LocalTime
import Data.Time.Calendar.Days
import Data.Time.Clock
import Control.DeepSeq
import Data.Typeable
import Data.Fixed
#if LANGUAGE_Rank2Types
import Data.Data
#endif

-- | AbsoluteTime is TAI, time as measured by a clock.
newtype AbsoluteTime = MkAbsoluteTime {unAbsoluteTime :: DiffTime} deriving (Eq,Ord
#if LANGUAGE_DeriveDataTypeable
#if LANGUAGE_Rank2Types
#if HAS_DataPico
    ,Data, Typeable
#endif
#endif
#endif
    )

instance NFData AbsoluteTime where
    rnf (MkAbsoluteTime a) = rnf a

instance Show AbsoluteTime where
    show t = show (utcToLocalTime utc (taiToUTCTime (const 0) t)) ++ " TAI" -- ugly, but standard apparently

-- | The epoch of TAI, which is 1858-11-17 00:00:00 TAI.
taiEpoch :: AbsoluteTime
taiEpoch = MkAbsoluteTime 0

-- | addAbsoluteTime a b = a + b
addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime
addAbsoluteTime t (MkAbsoluteTime a) = MkAbsoluteTime (a + t)

-- | diffAbsoluteTime a b = a - b
diffAbsoluteTime :: AbsoluteTime -> AbsoluteTime -> DiffTime
diffAbsoluteTime (MkAbsoluteTime a) (MkAbsoluteTime b) = a - b

-- | TAI - UTC during this day.
-- No table is provided, as any program compiled with it would become
-- out of date in six months.
type LeapSecondTable = Day -> Integer

utcDayLength :: LeapSecondTable -> Day -> DiffTime
utcDayLength table day = realToFrac (86400 + (table (addDays 1 day)) - (table day))

dayStart :: LeapSecondTable -> Day -> AbsoluteTime
dayStart table day = MkAbsoluteTime    (realToFrac ((toModifiedJulianDay day) * 86400 + (table day)))

utcToTAITime :: LeapSecondTable -> UTCTime -> AbsoluteTime
utcToTAITime table (UTCTime day dtime) = MkAbsoluteTime (t + dtime) where
    MkAbsoluteTime t = dayStart table day

taiToUTCTime :: LeapSecondTable -> AbsoluteTime -> UTCTime
taiToUTCTime table abstime = stable (ModifiedJulianDay (div' (unAbsoluteTime abstime) 86400)) where
    stable day = if (day == day') then UTCTime day dtime else stable day' where
        dayt = dayStart table day
        dtime = diffAbsoluteTime abstime dayt
        day' = addDays (div' dtime (utcDayLength table day)) day

-- | Parse the contents of a tai-utc.dat file.
-- This does not do any kind of validation and will return a bad table for input
-- not in the correct format.
parseTAIUTCDATFile :: String -> LeapSecondTable
parseTAIUTCDATFile ss = offsetlist 0 (parse (lines ss)) where
    offsetlist :: Integer -> [(Day,Integer)] -> LeapSecondTable
    offsetlist i [] _ = i
    offsetlist i ((d0,_):_) d | d < d0 = i
    offsetlist _ ((_,i0):xx) d = offsetlist i0 xx d

    parse :: [String] -> [(Day,Integer)]
    parse [] = []
    parse (a:as) = let
        ps = parse as
     in case matchLine a of
        Just di -> di:ps
        Nothing -> ps

    matchLine :: String -> Maybe (Day,Integer)
    matchLine s = do
        check0S s
        (d,s') <- findJD s
        i <- findOffset s'
        return (d,i)

    -- a bit fragile
    check0S :: String -> Maybe ()
    check0S "X 0.0      S" = Just ()
    check0S [] = Nothing
    check0S (_:cs) = check0S cs

    findJD :: String -> Maybe (Day,String)
    findJD ('=':'J':'D':s) = do
        d <- getInteger '5' s
        return (ModifiedJulianDay (d - 2400000),s)
    findJD [] = Nothing
    findJD (_:cs) = findJD cs

    findOffset :: String -> Maybe Integer
    findOffset ('T':'A':'I':'-':'U':'T':'C':'=':s) = getInteger '0' s
    findOffset [] = Nothing
    findOffset (_:cs) = findOffset cs

    getInteger :: Char -> String -> Maybe Integer
    getInteger p s = do
        digits <- getDigits p s
        fromDigits 0 digits

    getDigits :: Char -> String -> Maybe String
    getDigits p (' ':s) = getDigits p s
    getDigits p (c:cs) | c >= '0' && c <= '9' = do
        s <- getDigits p cs
        return (c:s)
    getDigits p ('.':p1:_) = if p == p1 then Just [] else Nothing
    getDigits _ _ = Nothing


    fromDigits :: Integer -> String -> Maybe Integer
    fromDigits i [] = Just i
    fromDigits i (c:cs) | c >= '0' && c <= '9' = fromDigits ((i * 10) + (fromIntegral ((fromEnum c) - (fromEnum '0')))) cs
    fromDigits _ _ = Nothing

-- typical line format:
-- 1972 JAN  1 =JD 2441317.5  TAI-UTC=  10.0       S + (MJD - 41317.) X 0.0      S
-- 1972 JUL  1 =JD 2441499.5  TAI-UTC=  11.0       S + (MJD - 41317.) X 0.0      S