{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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

    , addTAI64
    , diffTAI64
    , sumTAI64
    , subTAI64

    , toAbsoluteTime
    , fromAbsoluteTime

    -- * @libtai@ compatibility
    -- $libtai
    , Libtai
    , libtai
    , unLibtai

    , taia_now
    , tai64nlocal

    , libtaiToUTC
    , libtaiToPOSIX
    , libtaiLabel

    , sumLibtai
    , subLibtai
    , addLibtai
    , diffLibtai

    -- * External representation
    , Label (..)
    , fromLabel

    , 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
import           Data.Time.Clock.POSIX
import           Data.Time.Clock.TAI
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'

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 === fromAbsoluteTime (addAbsoluteTime d (toAbsoluteTime t))
--
addTAI64 :: DiffTime -> TAI64 -> TAI64
addTAI64 d = sumTAI64 (fromDiffTime d)

-- | diffTAI64 a b = a - b
--
--
-- Properties:
--
-- prop> \(PicosecondResolution a) (PicosecondResolution b) -> b <= a && toAbsoluteTime b >= taiEpoch ==> diffTAI64 a b === diffAbsoluteTime (toAbsoluteTime a) (toAbsoluteTime b)
--
diffTAI64 :: TAI64 -> TAI64 -> DiffTime
diffTAI64 a = toDiffTime . subTAI64 a
-- FIXME: why are 'AbsoluteTime's before 'taiEpoch' subject to rounding errors?

-- | 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 'AbsoluteTime'.
--
-- Note that 'AbsoluteTime' has only picosecond resolution, hence the conversion
-- is lossy.
--
-- Properties:
--
-- prop> \(PicosecondResolution x) -> (fromAbsoluteTime . toAbsoluteTime) x === x
--
toAbsoluteTime :: TAI64 -> AbsoluteTime
toAbsoluteTime (TAI64 s n as)
    | s >= 0   && s < piv = before1970 (secs (piv - s))
    | s >= piv && s < upp = after1970  (secs (s - piv))
    | otherwise = error "Outside universe lifetime"
  where
    before1970
        = addAbsoluteTime (negate attos)
        . addAbsoluteTime (negate nanos)
        . (`addAbsoluteTime` tai64Epoch)
        . negate
    after1970
        = addAbsoluteTime attos
        . addAbsoluteTime nanos
        . (`addAbsoluteTime` tai64Epoch)

    secs :: Word64 -> DiffTime
    secs = secondsToDiffTime . fromIntegral

    nanos = picosecondsToDiffTime (fromIntegral  n *        1000)
    attos = picosecondsToDiffTime (fromIntegral as `div` 1000000)

-- | Obtain a 'TAI64' label from 'AbsoluteTime'.
--
--
-- Properties:
--
-- prop> (toAbsoluteTime . fromAbsoluteTime) x === x
--
fromAbsoluteTime :: AbsoluteTime -> TAI64
fromAbsoluteTime = mk . diffAbsoluteTime tai64Epoch
  where
    mk d = let (TAI64 s n as) = fromDiffTime d
            in TAI64 (piv - s) n as


-- $libtai
-- <http://cr.yp.to/libtai.html libtai> employs a means of dealing with leap
-- seconds which is broken in several ways. As an artifact of this, the
-- @taia_now@ function employed by both @daemontools@ and @runit@ produces
-- \"taistamps\" which do not consider leap seconds, but are offset from
-- 1970-01-01 00:00:00 UTC by 10s + 500ns (the purpose of the latter is
-- unclear, as conversion functions seem to ignore it). Obviously, this violates
-- it's own spec, yet (perhaps ironically) allows conversion back to UTC or
-- local time without the need for a leap second table.
--
-- For compatibility and convenience, we provide some machinery to deal with
-- TAI64 labels generated by these programs.
--

-- | Represents a 'TAI64' label obtained by ignoring leap seconds, and offset
-- from 1970-01-01 00:00:00 UTC by 10.0000005s
--
newtype Libtai = Libtai TAI64
    deriving (Eq, Show, Ord, Bounded, Arbitrary)


-- unfortunately, there doesn't seem to be a way to derive unboxed vectors
-- through GeneralizedNewtypeDeriving, so we need to repeat the boilerplate
-- below.

newtype instance MVector s Libtai = MV_Libtai (MVector s TAI64)
newtype instance Vector    Libtai = V_Libtai  (Vector    TAI64)

instance VM.MVector MVector Libtai 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_Libtai x)
        = VM.basicLength x
    basicUnsafeSlice i n (MV_Libtai v)
        = MV_Libtai $ VM.basicUnsafeSlice i n v
    basicOverlaps (MV_Libtai v1) (MV_Libtai v2)
        = VM.basicOverlaps v1 v2
    basicUnsafeNew n
        = MV_Libtai `liftM` VM.basicUnsafeNew n
#if MIN_VERSION_vector(0,11,0)
    basicInitialize (MV_Libtai v)
        = VM.basicInitialize v
    {-# INLINE basicInitialize      #-}
#endif
    basicUnsafeReplicate n (Libtai tai)
        = MV_Libtai `liftM` VM.basicUnsafeReplicate n tai
    basicUnsafeRead (MV_Libtai v) i
        = Libtai `liftM` VM.basicUnsafeRead v i
    basicUnsafeWrite (MV_Libtai v) i (Libtai tai)
        = VM.basicUnsafeWrite v i tai
    basicClear (MV_Libtai v)
        = VM.basicClear v
    basicSet (MV_Libtai v) (Libtai tai)
        = VM.basicSet v tai
    basicUnsafeCopy (MV_Libtai v1) (MV_Libtai v2)
        = VM.basicUnsafeCopy v1 v2
    basicUnsafeMove (MV_Libtai v1) (MV_Libtai v2)
        = VM.basicUnsafeMove v1 v2
    basicUnsafeGrow (MV_Libtai v) n
        = MV_Libtai `liftM` VM.basicUnsafeGrow v n

instance VG.Vector Vector Libtai where
    {-# INLINE basicUnsafeFreeze #-}
    {-# INLINE basicUnsafeThaw   #-}
    {-# INLINE basicLength       #-}
    {-# INLINE basicUnsafeSlice  #-}
    {-# INLINE basicUnsafeIndexM #-}
    {-# INLINE elemseq           #-}
    basicUnsafeFreeze (MV_Libtai v)
        = V_Libtai `liftM` VG.basicUnsafeFreeze v
    basicUnsafeThaw (V_Libtai v)
        = MV_Libtai `liftM` VG.basicUnsafeThaw v
    basicLength (V_Libtai v)
        = VG.basicLength v
    basicUnsafeSlice i n (V_Libtai v)
        = V_Libtai $ VG.basicUnsafeSlice i n v
    basicUnsafeIndexM (V_Libtai v) i
        = Libtai `liftM` VG.basicUnsafeIndexM v i
    basicUnsafeCopy (MV_Libtai mv) (V_Libtai v)
        = VG.basicUnsafeCopy mv v
    elemseq _ (Libtai tai) z
        = VG.elemseq (undefined :: Vector a) tai z

instance Unbox Libtai


-- | Tag a 'TAI64' value as being created by a @libtai@-compatible program.
--
-- Note that this lowers precision to nanoseconds.
--
libtai :: TAI64 -> Libtai
libtai tai = Libtai tai { taiAttos = 0 }

-- | Obtain a proper 'TAI64' from 'Libtai'
--
-- Note that this is relatively expensive, as it needs to convert to 'UTCTime'
-- first before applying the 'LeapSecondTable'.
--
unLibtai :: LeapSecondTable -> Libtai -> TAI64
unLibtai lst = fromAbsoluteTime . utcToTAITime lst . libtaiToUTC

-- | Obtain the current time as 'Libtai'.
--
-- This is (bug-)compatible with the function of the same name from @libtai@: we
-- just obtain the current 'POSIXTime' and apply an offset of 10.0000005s.
--
taia_now :: IO Libtai
taia_now = do
    posix <- getPOSIXTime
    let tai = fromDiffTime (realToFrac posix)
    pure . Libtai $ tai
        { taiSecs  = taiSecs  tai + piv + 10
        , taiNanos = taiNanos tai + 500
        , taiAttos = 0
        }

-- | Obtain the local time corresponding to 'Libtai'.
--
-- This is compatible with the program of the same name from the @daemontools@
-- suite.
--
-- >>> let tai64n  = "4000000057693ef01cf4d1a4" -- generated by 'tai64n' from 'daemontools'
-- >>> let Right t = libtai <$> fromText tai64n
-- >>> let cest    = TimeZone (60 * 2) True "CEST"
-- >>> utcToZonedTime cest (libtaiToUTC t)
-- 2016-06-21 15:19:34.4858065 CEST
--
tai64nlocal :: Libtai -> IO ZonedTime
tai64nlocal t = utcToZonedTime <$> getCurrentTimeZone <*> pure (libtaiToUTC t)

-- | Obtain the 'UTCTime' used to generate 'Libtai'.
libtaiToUTC :: Libtai -> UTCTime
libtaiToUTC = posixSecondsToUTCTime . libtaiToPOSIX

-- | Obtain the 'POSIXTime' used to generate 'Libtai'.
libtaiToPOSIX :: Libtai -> POSIXTime
libtaiToPOSIX (Libtai tai)
    -- nb. the 500ns added by 'taia_now' are _not_ subtracted here again!
    = realToFrac . toDiffTime $ tai { taiSecs = taiSecs tai - piv - 10 }

-- | Obtain a 'Label' for 'Libtai'. Note that this is always 'TAI64N'.
--
-- >>> let tai64n  = "4000000057693ef01cf4d1a4" -- generated by 'tai64n' from 'daemontools'
-- >>> toText . libtaiLabel . libtai <$> fromText tai64n
-- Right "4000000057693ef01cf4d1a4"
--
libtaiLabel :: Libtai -> Label
libtaiLabel (Libtai tai) = TAI64N tai

-- | Addition of 'Libtai' values.
sumLibtai :: Libtai -> Libtai -> Libtai
sumLibtai (Libtai a) (Libtai b) = Libtai $ sumTAI64 a b

-- | Subtraction of 'Libtai' values.
subLibtai :: Libtai -> Libtai -> Libtai
subLibtai (Libtai a) (Libtai b) = Libtai $ subTAI64 a b

-- | Add 'DiffTime' to 'Libtai'.
addLibtai :: DiffTime -> Libtai -> Libtai
addLibtai d (Libtai t) = Libtai $ addTAI64 d t

-- | Subtraction of 'Libtai' values, yielding 'DiffTime'.
diffLibtai :: Libtai -> Libtai -> DiffTime
diffLibtai (Libtai a) (Libtai b) = diffTAI64 a b


--------------------------------------------------------------------------------
-- External Representation                                                    --
--------------------------------------------------------------------------------

-- | 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)


-- | 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 #-}


-- | 1970-01-01 00:00:00 TAI
tai64Epoch :: AbsoluteTime
tai64Epoch = addAbsoluteTime (secondsToDiffTime 3506716800) taiEpoch

piv,upp :: Word64
piv = 2^(62 :: Int)
upp = 2^(63 :: Int)