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
data TAI64 = TAI64
{ taiSecs :: !Word64
, taiNanos :: !Word32
, taiAttos :: !Word32
} 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)
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'
data Label
= TAI64S !TAI64
| TAI64N !TAI64
| TAI64NA !TAI64
deriving Show
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
]
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
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
#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
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 :: DiffTime -> TAI64 -> TAI64
addTAI64 d = sumTAI64 (fromDiffTime d)
diffTAI64 :: TAI64 -> TAI64 -> DiffTime
diffTAI64 a = toDiffTime . subTAI64 a
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 :: 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'
toUTCTime :: TAI64 -> UTCTime
toUTCTime = posixSecondsToUTCTime . toPOSIXTime
fromUTCTime :: UTCTime -> TAI64
fromUTCTime = fromPOSIXTime . utcTimeToPOSIXSeconds
toPOSIXTime :: TAI64 -> POSIXTime
toPOSIXTime = subtract (2^(62 :: Int)) . subtract 10 . realToFrac . toDiffTime
fromPOSIXTime :: POSIXTime -> TAI64
fromPOSIXTime = fromDiffTime . realToFrac . (+ 2^(62 :: Int)) . (+ 10)
toText :: Label -> Text
toText = decodeUtf8 . toByteString
fromText :: Text -> Either String TAI64
fromText = PT.parseOnly parseText
toByteString :: Label -> ByteString
toByteString = BL.toStrict . Hex.encode . Binary.encode
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 '@'
instance ParseInput ByteString where
_parseOnly = PB.parseOnly
_take = PB.take
_hexadecimal = PB.hexadecimal
_at = PB.char '@'
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
parseText :: Parser Text TAI64
parseText = parse
parseByteString :: Parser ByteString TAI64
parseByteString = parse
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
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))