{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Chrono.TimeStamp
(
TimeStamp(..)
, getCurrentTimeNanoseconds
, ISO8601_Precise(..)
) where
import Control.Applicative
import Data.Aeson
import Data.Aeson.Types (typeMismatch)
import Data.Aeson.Encoding (string)
import Data.Maybe
import Data.Int (Int64)
import Data.Hourglass
import qualified Data.Text as T
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Generic.Mutable as M
import Data.Vector.Unboxed
import GHC.Generics
import Time.System
import Chrono.Formats
newtype TimeStamp = TimeStamp {
unTimeStamp :: Int64
} deriving (Eq, Ord, Enum, Num, Real, Integral, Bounded, Generic)
instance Timeable TimeStamp where
timeGetElapsedP :: TimeStamp -> ElapsedP
timeGetElapsedP (TimeStamp ticks) =
let
(s,ns) = divMod ticks 1000000000
in
ElapsedP (Elapsed (Seconds (s))) (NanoSeconds (ns))
instance Time TimeStamp where
timeFromElapsedP :: ElapsedP -> TimeStamp
timeFromElapsedP (ElapsedP (Elapsed (Seconds seconds)) (NanoSeconds nanoseconds)) =
let
s = fromIntegral seconds :: Int64
ns = fromIntegral nanoseconds
in
TimeStamp $! (s * 1000000000) + ns
instance Show TimeStamp where
show t = timePrint ISO8601_Precise t
instance Read TimeStamp where
readsPrec _ s = maybeToList $ (,"") <$> parseInput s
parseInput :: String -> Maybe TimeStamp
parseInput = fmap reduceDateTime . parse
where
parse :: String -> Maybe DateTime
parse x =
timeParse ISO8601_Precise x
<|> timeParse ISO8601_Seconds x
<|> timeParse ISO8601_DateAndTime x
<|> timeParse ISO8601_Date x
<|> timeParse Posix_Precise x
<|> timeParse Posix_Micro x
<|> timeParse Posix_Milli x
<|> timeParse Posix_Seconds x
reduceDateTime :: DateTime -> TimeStamp
reduceDateTime = timeFromElapsedP . timeGetElapsedP
getCurrentTimeNanoseconds :: IO TimeStamp
getCurrentTimeNanoseconds = do
p <- timeCurrentP
return $! convertToTimeStamp p
convertToTimeStamp :: ElapsedP -> TimeStamp
convertToTimeStamp = timeFromElapsedP
newtype instance MVector s TimeStamp = MV_TimeStamp (MVector s Int64)
newtype instance Vector TimeStamp = V_TimeStamp (Vector Int64)
instance G.Vector Vector TimeStamp where
basicUnsafeFreeze (MV_TimeStamp v) = V_TimeStamp <$> G.basicUnsafeFreeze v
basicUnsafeThaw (V_TimeStamp v) = MV_TimeStamp <$> G.basicUnsafeThaw v
basicLength (V_TimeStamp v) = G.basicLength v
basicUnsafeSlice j k (V_TimeStamp v) = V_TimeStamp $ G.basicUnsafeSlice j k v
basicUnsafeIndexM (V_TimeStamp v) i = TimeStamp <$> G.basicUnsafeIndexM v i
{-# INLINE basicUnsafeFreeze #-}
{-# INLINE basicUnsafeThaw #-}
{-# INLINE basicLength #-}
{-# INLINE basicUnsafeSlice #-}
{-# INLINE basicUnsafeIndexM #-}
instance M.MVector MVector TimeStamp where
basicLength (MV_TimeStamp v) = M.basicLength v
basicUnsafeSlice j k (MV_TimeStamp v) = MV_TimeStamp $ M.basicUnsafeSlice j k v
basicOverlaps (MV_TimeStamp a) (MV_TimeStamp b) = M.basicOverlaps a b
basicUnsafeNew n = MV_TimeStamp <$> M.basicUnsafeNew n
basicInitialize (MV_TimeStamp v) = M.basicInitialize v
basicUnsafeRead (MV_TimeStamp v) i = TimeStamp <$> M.basicUnsafeRead v i
basicUnsafeWrite (MV_TimeStamp v) i (TimeStamp a) = M.basicUnsafeWrite v i a
{-# INLINE basicLength #-}
{-# INLINE basicUnsafeSlice #-}
{-# INLINE basicOverlaps #-}
{-# INLINE basicUnsafeNew #-}
{-# INLINE basicInitialize #-}
{-# INLINE basicUnsafeRead #-}
{-# INLINE basicUnsafeWrite #-}
deriving instance Unbox TimeStamp
instance ToJSON TimeStamp where
toEncoding = string . timePrint ISO8601_Precise
instance FromJSON TimeStamp where
parseJSON (String value) =
let
str = T.unpack value
result = parseInput str
in
case result of
Just t -> pure t
Nothing -> fail "Unable to parse input as a TimeStamp"
parseJSON (invalid) = typeMismatch "TimeStamp" invalid