{-# LANGUAGE CPP                   #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}

{-# OPTIONS_HADDOCK show-extensions #-}


-- |
-- Module      : Data.Time.Clock.TAI64
-- Description : TAI64 labels
-- Copyright   : (c) 2015-2016 Kim Altintop <kim.altintop@gmail.com>
-- License     : MPL
-- Maintainer  : Kim Altintop <kim.altintop@gmail.com>
-- Stability   : experimental
-- Portability : GHC
--
--
-- Implementation of TAI64 labels as specified by
-- <http://cr.yp.to/libtai/tai64.html>
--
-- Mainly useful for working with logfiles generated by \"multilog\" (part of
-- the <http://cr.yp.to/daemontools.html daemontools> suite) or \"svlogd\" (part
-- of the <http://smarden.org/runit/ runit> suite).
--
module Data.Time.Clock.TAI64
    ( TAI64
    , tai64
    , taiSecs
    , taiNanos
    , taiAttos

    , Label (..)
    , fromLabel

    , addTAI64
    , diffTAI64

    , sumTAI64
    , subTAI64

    , toUTCTime
    , fromUTCTime
    , toPOSIXTime
    , fromPOSIXTime

    , toText
    , fromText
    , toByteString
    , fromByteString

    , parse
    , parseText
    , parseByteString
    )
where

import           Control.Applicative
import           Control.Monad                    (liftM)
import qualified Data.Attoparsec.ByteString.Char8 as PB
import           Data.Attoparsec.Combinator       (option)
import           Data.Attoparsec.Internal.Types   (Parser)
import qualified Data.Attoparsec.Text             as PT
import           Data.Binary
import qualified Data.Binary                      as Binary
import           Data.Binary.Get
import           Data.Binary.Put
import           Data.Bits
import           Data.ByteString                  (ByteString)
import qualified Data.ByteString.Base16.Lazy      as Hex
import qualified Data.ByteString.Lazy             as BL
import           Data.Text                        (Text)
import           Data.Text.Encoding               (decodeUtf8)
import           Data.Time.Clock
import           Data.Time.Clock.POSIX
import qualified Data.Vector.Generic              as VG
import qualified Data.Vector.Generic.Mutable      as VM
import           Data.Vector.Unboxed.Base
import           Test.QuickCheck


-- $setup
-- >>> :set -XScopedTypeVariables
-- >>> :set -XOverloadedStrings
-- >>> import Data.Monoid
-- >>> import Data.Time.Clock.TAI
-- >>> import System.IO
-- >>> lst <- parseTAIUTCDATFile <$> readFile "tai-utc.dat"
-- >>> :{
--  instance Arbitrary DiffTime where
--      arbitrary = secondsToDiffTime <$> arbitrary
--  instance Arbitrary NominalDiffTime where
--      arbitrary = realToFrac <$> arbitrary
--  instance Arbitrary AbsoluteTime where
--      arbitrary = (`addAbsoluteTime` taiEpoch) <$> arbitrary
--  instance Arbitrary UTCTime where
--      arbitrary = taiToUTCTime lst <$> arbitrary
--  newtype PicosecondResolution = PicosecondResolution TAI64 deriving Show
--  instance Arbitrary PicosecondResolution where
--      arbitrary = do
--          t <- TAI64 <$> choose (0, (2^(63 :: Int)) -1)
--                     <*> choose (0, 999999999)
--                     <*> elements [0,1000000..999000000]
--          pure $ PicosecondResolution t
-- :}

-- | Representation of a TAI64 label with full precision
data TAI64 = TAI64
    { taiSecs  :: {-# UNPACK #-} !Word64
    -- ^ Seconds of real time.
    --
    -- @
    -- Integer s refers to
    --
    --   * the TAI second beginning exactly 2^62 - s seconds before the
    --     beginning of 1970 TAI, if s is between 0 inclusive and 2^62 exclusive;
    --   * or the TAI second beginning exactly s - 2^62 seconds after the
    --     beginning of 1970 TAI, if s is between 2^62 inclusive and 2^63
    --     exclusive.
    --
    -- Integers 2^63 and larger are reserved for future extensions. Under many
    -- cosmological theories, the integers under 2^63 are adequate to cover the
    -- entire expected lifetime of the universe; in this case no extensions will
    -- be necessary.
    -- @
    , taiNanos :: {-# UNPACK #-} !Word32
    -- ^ Nanoseconds @[0 .. 999999999]@
    , taiAttos :: {-# UNPACK #-} !Word32
    -- ^ Attoseconds @[0 .. 999999999]@
    } deriving (Eq, Show, Ord)

instance Bounded TAI64 where
    minBound = TAI64 0 0 0
    maxBound = TAI64 maxBound 999999999 999999999

instance Arbitrary TAI64 where
    arbitrary = TAI64
        <$> choose (0, (2^(63 :: Int)) - 1)
        <*> choose (0, 999999999)
        <*> choose (0, 999999999)


-- | Construct a 'TAI64' from seconds, nanoseconds and attoseconds
--
tai64 :: Word64 -> Word32 -> Word32 -> TAI64
tai64 s n as
    | n  > 999999999 = if s >= maxBound - 1 then
                           maxBound
                       else
                           tai64 (s + 1) (n - 1000000000) as
    | as > 999999999 = tai64 s (n + 1) (as - 1000000000)
    | otherwise      = let (s', n' ) = divMod n  1000000000
                           (n'',as') = divMod as 1000000000
                           secs      = s + fromIntegral s'
                        in TAI64 (if secs < s then maxBound else secs)
                                 (n' + n'')
                                 as'

-- | A TAI64 label with precision as denoted by the data constructor. This is
-- used to render the \"external\" (cf. 'toText', 'toByteString') respectively
-- binary representation.
--
data Label
    = TAI64S  {-# UNPACK #-} !TAI64
    | TAI64N  {-# UNPACK #-} !TAI64
    | TAI64NA {-# UNPACK #-} !TAI64
    deriving Show

-- | Get the 'TAI64' stamp from the 'Label', truncated to the precision as
-- denoted by the 'Label''s data constructor.
--
fromLabel :: Label -> TAI64
fromLabel (TAI64S  t) = t { taiNanos = 0, taiAttos = 0 }
fromLabel (TAI64N  t) = t { taiAttos = 0 }
fromLabel (TAI64NA t) = t

instance Eq Label where
    a == b = case a of
        TAI64S  (TAI64 s _ _ ) -> s == s'
        TAI64N  (TAI64 s n _ ) -> s == s' && n == n'
        TAI64NA (TAI64 s n as) -> s == s' && n == n' && as == as'
      where
        (TAI64 s' n' as') = fromLabel b

instance Ord Label where
    a <= b = case a of
        TAI64S  (TAI64 s _ _ ) -> s <= s' && 0 <= n' &&  0 <= as'
        TAI64N  (TAI64 s n _ ) -> s <= s' && n <= n' &&  0 <= as'
        TAI64NA (TAI64 s n as) -> s <= s' && n <= n' && as <= as'
      where
        (TAI64 s' n' as') = fromLabel b

instance Arbitrary Label where
    arbitrary = oneof
        [ TAI64S  <$> arbitrary
        , TAI64N  <$> arbitrary
        , TAI64NA <$> arbitrary
        ]

-- | External representation of a 'Label'
--
-- * 'TAI64S': eight 8-bit bytes, big-endian, encoding the second
-- * 'TAI64N': twelve 8-bit bytes, big-endian, encoding the second, followed by
-- the nanosecond
-- * 'TAI64NA': sixteen 8-bit bytes, big-endian, encoding the second, followed
-- by the nanosecond, followed by the attosecond
--
--
-- Properties:
--
-- prop> (Binary.decode . Binary.encode) x == x
--
instance Binary Label where
    put (TAI64S  tai) = putWord64be (taiSecs tai)
    put (TAI64N  tai) = putWord64be (taiSecs tai) *> putWord32be (taiNanos tai)
    put (TAI64NA tai) = putWord64be (taiSecs tai) *> putWord32be (taiNanos tai)
                                                  *> putWord32be (taiAttos tai)

    get = do
        elts <- (,,) <$> getWord64be
                     <*> optional getWord32be
                     <*> optional getWord32be
        pure $ case elts of
            (s, Just  n, Just  a) -> TAI64NA (TAI64 s n a)
            (s, Just  n, Nothing) -> TAI64N  (TAI64 s n 0)
            (s, Nothing, Nothing) -> TAI64S  (TAI64 s 0 0)
            (s, Nothing, Just  n) -> TAI64N  (TAI64 s n 0)


newtype instance MVector s TAI64 = MV_TAI64 (MVector s (Word64,Word32,Word32))
newtype instance Vector    TAI64 = V_TAI64  (Vector    (Word64,Word32,Word32))

instance VM.MVector MVector TAI64 where
    {-# INLINE basicLength          #-}
    {-# INLINE basicUnsafeSlice     #-}
    {-# INLINE basicOverlaps        #-}
    {-# INLINE basicUnsafeNew       #-}
    {-# INLINE basicUnsafeReplicate #-}
    {-# INLINE basicUnsafeRead      #-}
    {-# INLINE basicUnsafeWrite     #-}
    {-# INLINE basicClear           #-}
    {-# INLINE basicSet             #-}
    {-# INLINE basicUnsafeCopy      #-}
    {-# INLINE basicUnsafeGrow      #-}
    basicLength (MV_TAI64 x)
        = VM.basicLength x
    basicUnsafeSlice i n (MV_TAI64 v)
        = MV_TAI64 $ VM.basicUnsafeSlice i n v
    basicOverlaps (MV_TAI64 v1) (MV_TAI64 v2)
        = VM.basicOverlaps v1 v2
    basicUnsafeNew n
        = MV_TAI64 `liftM` VM.basicUnsafeNew n
#if MIN_VERSION_vector(0,11,0)
    basicInitialize (MV_TAI64 v)
        = VM.basicInitialize v
    {-# INLINE basicInitialize      #-}
#endif
    basicUnsafeReplicate n (TAI64 s n' a)
        = MV_TAI64 `liftM` VM.basicUnsafeReplicate n (s,n',a)
    basicUnsafeRead (MV_TAI64 v) i
        = (\(s,n,a) -> TAI64 s n a) `liftM` VM.basicUnsafeRead v i
    basicUnsafeWrite (MV_TAI64 v) i (TAI64 s n a)
        = VM.basicUnsafeWrite v i (s,n,a)
    basicClear (MV_TAI64 v)
        = VM.basicClear v
    basicSet (MV_TAI64 v) (TAI64 s n a)
        = VM.basicSet v (s,n,a)
    basicUnsafeCopy (MV_TAI64 v1) (MV_TAI64 v2)
        = VM.basicUnsafeCopy v1 v2
    basicUnsafeMove (MV_TAI64 v1) (MV_TAI64 v2)
        = VM.basicUnsafeMove v1 v2
    basicUnsafeGrow (MV_TAI64 v) n
        = MV_TAI64 `liftM` VM.basicUnsafeGrow v n

instance VG.Vector Vector TAI64 where
    {-# INLINE basicUnsafeFreeze #-}
    {-# INLINE basicUnsafeThaw   #-}
    {-# INLINE basicLength       #-}
    {-# INLINE basicUnsafeSlice  #-}
    {-# INLINE basicUnsafeIndexM #-}
    {-# INLINE elemseq           #-}
    basicUnsafeFreeze (MV_TAI64 v)
        = V_TAI64 `liftM` VG.basicUnsafeFreeze v
    basicUnsafeThaw (V_TAI64 v)
        = MV_TAI64 `liftM` VG.basicUnsafeThaw v
    basicLength (V_TAI64 v)
        = VG.basicLength v
    basicUnsafeSlice i n (V_TAI64 v)
        = V_TAI64 $ VG.basicUnsafeSlice i n v
    basicUnsafeIndexM (V_TAI64 v) i
        = (\(s,n,a) -> TAI64 s n a) `liftM` VG.basicUnsafeIndexM v i
    basicUnsafeCopy (MV_TAI64 mv) (V_TAI64 v)
        = VG.basicUnsafeCopy mv v
    elemseq _ (TAI64 s n a) z
        = VG.elemseq (undefined :: Vector a) s
        $ VG.elemseq (undefined :: Vector a) n
        $ VG.elemseq (undefined :: Vector a) a z

instance Unbox TAI64


-- | addTAI64 a b = a + b
--
--
-- Properties:
--
-- prop> \d (PicosecondResolution t) -> addTAI64 d t === fromUTCTime (addUTCTime (realToFrac d) (toUTCTime t))
--
addTAI64 :: DiffTime -> TAI64 -> TAI64
addTAI64 d = sumTAI64 (fromDiffTime d)

-- | diffTAI64 a b = a - b
--
--
-- Properties:
--
-- prop> \(PicosecondResolution a) (PicosecondResolution b) -> b <= a ==> diffTAI64 a b === realToFrac (diffUTCTime (toUTCTime a) (toUTCTime b))
--
diffTAI64 :: TAI64 -> TAI64 -> DiffTime
diffTAI64 a = toDiffTime . subTAI64 a

-- | sumTAI64 a b = a + b
--
--
-- Properties:
--
-- prop> sumTAI64 a b >= a
-- prop> sumTAI64 a minBound === a
-- prop> sumTAI64 b a === sumTAI64 a b
-- prop> (a `sumTAI64` b) `sumTAI64` c === a `sumTAI64` (b `sumTAI64` c)
--
sumTAI64 :: TAI64 -> TAI64 -> TAI64
sumTAI64 a b =
    let secs  = taiSecs  a + taiSecs  b
        nanos = taiNanos a + taiNanos b
        attos = taiAttos a + taiAttos b
        (nanos',attos') = if attos > 999999999
                             then (nanos + 1, attos - 1000000000)
                             else (nanos, attos)
        (secs',nanos'') = if nanos > 999999999
                             then (secs + 1, nanos' - 1000000000)
                             else (secs, nanos')
     in TAI64 secs' nanos'' attos'

-- | subTAI64 a b = a - b
--
--
-- Properties:
--
-- prop> subTAI64 a b <= a
-- prop> b >= a ==> subTAI64 a b === minBound
-- prop> subTAI64 a minBound === a
--
subTAI64 :: TAI64 -> TAI64 -> TAI64
subTAI64 a b | b >= a = minBound
subTAI64 a b =
    let secs  = taiSecs  a - taiSecs  b
        nanos = taiNanos a - taiNanos b
        attos = taiAttos a - taiAttos b
        (nanos',attos') = if attos > taiAttos a
                             then (nanos - 1, attos + 1000000000)
                             else (nanos, attos)
        (secs',nanos'') = if nanos' > taiNanos a
                             then (secs - 1, nanos' + 1000000000)
                             else (secs, nanos')
     in TAI64 secs' nanos'' attos'

-- | Convert a 'TAI64' label to 'UTCTime'.
--
-- Note that 'UTCTime' has only picosecond precision, so the conversion is
-- lossy.
--
--
-- Properties:
--
-- prop> \(PicosecondResolution x) -> (fromUTCTime . toUTCTime) x === x
--
toUTCTime :: TAI64 -> UTCTime
toUTCTime = posixSecondsToUTCTime . toPOSIXTime

-- | Obtain a 'TAI64' label from 'UTCTime'.
--
--
-- Properties:
--
-- prop> (toUTCTime . fromUTCTime) x === x
--
fromUTCTime :: UTCTime -> TAI64
fromUTCTime = fromPOSIXTime . utcTimeToPOSIXSeconds

-- | Convert a 'TAI64' label to 'POSIXTime'.
--
-- Note that 'POSIXTime' has only picosecond precision, so the conversion is
-- lossy.
--
--
-- Properties:
--
-- prop> \(PicosecondResolution x) -> (fromPOSIXTime . toPOSIXTime) x === x
--
toPOSIXTime :: TAI64 -> POSIXTime
toPOSIXTime = subtract (2^(62 :: Int)) . subtract 10 . realToFrac . toDiffTime

-- | Obtain a 'TAI64' label from 'POSIXTime'
--
--
-- Properties:
--
-- prop> fromPOSIXTime x === fromUTCTime (posixSecondsToUTCTime x)
--
fromPOSIXTime :: POSIXTime -> TAI64
fromPOSIXTime = fromDiffTime . realToFrac . (+ 2^(62 :: Int)) . (+ 10)

-- | Render a textual (ie. hexadecimal) representation of the /external/
-- TAI64{N,NA} format of the given 'Label'
--
--
-- Properties:
--
-- prop> (fromText . toText) x === Right (fromLabel x)
--
toText :: Label -> Text
toText = decodeUtf8 . toByteString

-- | Parse a 'TAI64' label from it's textual (hexadecimal) representation.
--
--
-- Properties:
--
-- prop> let x' = toText x in fromText x' === fromText ("@" <> x')
--
fromText :: Text -> Either String TAI64
fromText = PT.parseOnly parseText

-- | Render a textual (ie. hexadecimal) representation of the /external/
-- TAI64{N,NA} format of the given 'Label'
--
--
-- Properties:
--
-- prop> (fromByteString . toByteString) x === Right (fromLabel x)
--
toByteString :: Label -> ByteString
toByteString = BL.toStrict . Hex.encode . Binary.encode

-- | Parse a 'TAI64' label from it's textual (hexadecimal) representation.
--
--
-- Properties:
--
-- prop> let x' = toByteString x in fromByteString x' === fromByteString ("@" <> x')
--
fromByteString :: ByteString -> Either String TAI64
fromByteString = PB.parseOnly parseByteString


class ParseInput a where
    _parseOnly   :: Parser a b -> a -> Either String b
    _take        :: Int -> Parser a a
    _hexadecimal :: (Integral x, Bits x) => Parser a x
    _at          :: Parser a Char

instance ParseInput Text where
    _parseOnly   = PT.parseOnly
    _take        = PT.take
    _hexadecimal = PT.hexadecimal
    _at          = PT.char '@'
    {-# INLINE _parseOnly   #-}
    {-# INLINE _take        #-}
    {-# INLINE _hexadecimal #-}
    {-# INLINE _at          #-}

instance ParseInput ByteString where
    _parseOnly   = PB.parseOnly
    _take        = PB.take
    _hexadecimal = PB.hexadecimal
    _at          = PB.char '@'
    {-# INLINE _parseOnly   #-}
    {-# INLINE _take        #-}
    {-# INLINE _hexadecimal #-}
    {-# INLINE _at          #-}

-- | Attoparsec parser for the textual TAI64 format, generalized so it works for
-- both 'Text' and 'ByteString' input.
--
parse :: ParseInput a => Parser a TAI64
parse = TAI64 <$> (optional _at *> word64Hex)
              <*> option 0 word32Hex
              <*> option 0 word32Hex
  where
    word64Hex = runParser _hexadecimal =<< _take 16
    word32Hex = runParser _hexadecimal =<< _take  8

    runParser p = either fail return . _parseOnly p

-- | Type-specialisation of 'parse'
parseText :: Parser Text TAI64
parseText = parse

-- | Type-specialisation of 'parse'
parseByteString :: Parser ByteString TAI64
parseByteString = parse


--------------------------------------------------------------------------------
-- Internal                                                                   --
--------------------------------------------------------------------------------

fromDiffTime :: DiffTime -> TAI64
fromDiffTime d = TAI64 s n as
  where
    (s,f) = properFraction d
    n     = nanos f
    as    = attos f - (n * 10^(9 :: Int))

    nanos = truncate . (* 10^( 9 :: Int)) . abs
    attos = truncate . (* 10^(18 :: Int)) . abs
{-# INLINABLE fromDiffTime #-}

toDiffTime :: TAI64 -> DiffTime
toDiffTime (TAI64 s n as) = secs + nanos + attos
  where
    secs  = fromIntegral s
    nanos = fromRational (toRational n  * 10^^( -9 :: Int))
    attos = fromRational (toRational as * 10^^(-18 :: Int))
{-# INLINABLE toDiffTime #-}