{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Cardano.Slotting.Time (
  -- * System time
  SystemStart (..),

  -- * Relative time
  RelativeTime (..),
  addRelativeTime,
  diffRelativeTime,
  fromRelativeTime,
  multRelativeTime,
  toRelativeTime,

  -- * Nominal diff time
  multNominalDiffTime,

  -- * Slot length
  getSlotLength,
  mkSlotLength,

  -- ** Conversions
  slotLengthFromMillisec,
  slotLengthFromSec,
  slotLengthToMillisec,
  slotLengthToSec,

  -- ** opaque
  SlotLength,
) where

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Codec.Serialise
import Control.Exception (assert)
import Data.Aeson (FromJSON, ToJSON)
import Data.Fixed
import Data.Time (
  NominalDiffTime,
  UTCTime,
  addUTCTime,
  diffUTCTime,
  nominalDiffTimeToSeconds,
  secondsToNominalDiffTime,
 )
import GHC.Generics (Generic)
import NoThunks.Class (InspectHeap (..), NoThunks)
import Quiet

{-------------------------------------------------------------------------------
  System start
-------------------------------------------------------------------------------}

-- | System start
--
-- Slots are counted from the system start.
newtype SystemStart = SystemStart {SystemStart -> UTCTime
getSystemStart :: UTCTime}
  deriving (SystemStart -> SystemStart -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SystemStart -> SystemStart -> Bool
$c/= :: SystemStart -> SystemStart -> Bool
== :: SystemStart -> SystemStart -> Bool
$c== :: SystemStart -> SystemStart -> Bool
Eq, forall x. Rep SystemStart x -> SystemStart
forall x. SystemStart -> Rep SystemStart x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SystemStart x -> SystemStart
$cfrom :: forall x. SystemStart -> Rep SystemStart x
Generic)
  deriving (Context -> SystemStart -> IO (Maybe ThunkInfo)
Proxy SystemStart -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy SystemStart -> String
$cshowTypeOf :: Proxy SystemStart -> String
wNoThunks :: Context -> SystemStart -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> SystemStart -> IO (Maybe ThunkInfo)
noThunks :: Context -> SystemStart -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> SystemStart -> IO (Maybe ThunkInfo)
NoThunks) via InspectHeap SystemStart
  deriving (Int -> SystemStart -> ShowS
[SystemStart] -> ShowS
SystemStart -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SystemStart] -> ShowS
$cshowList :: [SystemStart] -> ShowS
show :: SystemStart -> String
$cshow :: SystemStart -> String
showsPrec :: Int -> SystemStart -> ShowS
$cshowsPrec :: Int -> SystemStart -> ShowS
Show) via Quiet SystemStart
  deriving newtype ([SystemStart] -> Encoding
SystemStart -> Encoding
forall s. Decoder s [SystemStart]
forall s. Decoder s SystemStart
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
decodeList :: forall s. Decoder s [SystemStart]
$cdecodeList :: forall s. Decoder s [SystemStart]
encodeList :: [SystemStart] -> Encoding
$cencodeList :: [SystemStart] -> Encoding
decode :: forall s. Decoder s SystemStart
$cdecode :: forall s. Decoder s SystemStart
encode :: SystemStart -> Encoding
$cencode :: SystemStart -> Encoding
Serialise)
  deriving newtype (Typeable SystemStart
SystemStart -> Encoding
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [SystemStart] -> Size
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy SystemStart -> Size
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> ToCBOR a
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [SystemStart] -> Size
$cencodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [SystemStart] -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy SystemStart -> Size
$cencodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy SystemStart -> Size
toCBOR :: SystemStart -> Encoding
$ctoCBOR :: SystemStart -> Encoding
ToCBOR, Typeable SystemStart
Proxy SystemStart -> Text
forall s. Decoder s SystemStart
forall a.
Typeable a
-> (forall s. Decoder s a) -> (Proxy a -> Text) -> FromCBOR a
label :: Proxy SystemStart -> Text
$clabel :: Proxy SystemStart -> Text
fromCBOR :: forall s. Decoder s SystemStart
$cfromCBOR :: forall s. Decoder s SystemStart
FromCBOR, [SystemStart] -> Encoding
[SystemStart] -> Value
SystemStart -> Bool
SystemStart -> Encoding
SystemStart -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: SystemStart -> Bool
$comitField :: SystemStart -> Bool
toEncodingList :: [SystemStart] -> Encoding
$ctoEncodingList :: [SystemStart] -> Encoding
toJSONList :: [SystemStart] -> Value
$ctoJSONList :: [SystemStart] -> Value
toEncoding :: SystemStart -> Encoding
$ctoEncoding :: SystemStart -> Encoding
toJSON :: SystemStart -> Value
$ctoJSON :: SystemStart -> Value
ToJSON, Maybe SystemStart
Value -> Parser [SystemStart]
Value -> Parser SystemStart
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
omittedField :: Maybe SystemStart
$comittedField :: Maybe SystemStart
parseJSONList :: Value -> Parser [SystemStart]
$cparseJSONList :: Value -> Parser [SystemStart]
parseJSON :: Value -> Parser SystemStart
$cparseJSON :: Value -> Parser SystemStart
FromJSON)

{-------------------------------------------------------------------------------
  Relative time
-------------------------------------------------------------------------------}

-- | 'RelativeTime' is time relative to the 'SystemStart'
--
-- Precision is in picoseconds
newtype RelativeTime = RelativeTime {RelativeTime -> NominalDiffTime
getRelativeTime :: NominalDiffTime}
  deriving stock (RelativeTime -> RelativeTime -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelativeTime -> RelativeTime -> Bool
$c/= :: RelativeTime -> RelativeTime -> Bool
== :: RelativeTime -> RelativeTime -> Bool
$c== :: RelativeTime -> RelativeTime -> Bool
Eq, Eq RelativeTime
RelativeTime -> RelativeTime -> Bool
RelativeTime -> RelativeTime -> Ordering
RelativeTime -> RelativeTime -> RelativeTime
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RelativeTime -> RelativeTime -> RelativeTime
$cmin :: RelativeTime -> RelativeTime -> RelativeTime
max :: RelativeTime -> RelativeTime -> RelativeTime
$cmax :: RelativeTime -> RelativeTime -> RelativeTime
>= :: RelativeTime -> RelativeTime -> Bool
$c>= :: RelativeTime -> RelativeTime -> Bool
> :: RelativeTime -> RelativeTime -> Bool
$c> :: RelativeTime -> RelativeTime -> Bool
<= :: RelativeTime -> RelativeTime -> Bool
$c<= :: RelativeTime -> RelativeTime -> Bool
< :: RelativeTime -> RelativeTime -> Bool
$c< :: RelativeTime -> RelativeTime -> Bool
compare :: RelativeTime -> RelativeTime -> Ordering
$ccompare :: RelativeTime -> RelativeTime -> Ordering
Ord, forall x. Rep RelativeTime x -> RelativeTime
forall x. RelativeTime -> Rep RelativeTime x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RelativeTime x -> RelativeTime
$cfrom :: forall x. RelativeTime -> Rep RelativeTime x
Generic)
  deriving newtype (Context -> RelativeTime -> IO (Maybe ThunkInfo)
Proxy RelativeTime -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy RelativeTime -> String
$cshowTypeOf :: Proxy RelativeTime -> String
wNoThunks :: Context -> RelativeTime -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> RelativeTime -> IO (Maybe ThunkInfo)
noThunks :: Context -> RelativeTime -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> RelativeTime -> IO (Maybe ThunkInfo)
NoThunks)
  deriving (Int -> RelativeTime -> ShowS
[RelativeTime] -> ShowS
RelativeTime -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelativeTime] -> ShowS
$cshowList :: [RelativeTime] -> ShowS
show :: RelativeTime -> String
$cshow :: RelativeTime -> String
showsPrec :: Int -> RelativeTime -> ShowS
$cshowsPrec :: Int -> RelativeTime -> ShowS
Show) via Quiet RelativeTime
  deriving newtype ([RelativeTime] -> Encoding
[RelativeTime] -> Value
RelativeTime -> Bool
RelativeTime -> Encoding
RelativeTime -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: RelativeTime -> Bool
$comitField :: RelativeTime -> Bool
toEncodingList :: [RelativeTime] -> Encoding
$ctoEncodingList :: [RelativeTime] -> Encoding
toJSONList :: [RelativeTime] -> Value
$ctoJSONList :: [RelativeTime] -> Value
toEncoding :: RelativeTime -> Encoding
$ctoEncoding :: RelativeTime -> Encoding
toJSON :: RelativeTime -> Value
$ctoJSON :: RelativeTime -> Value
ToJSON, Maybe RelativeTime
Value -> Parser [RelativeTime]
Value -> Parser RelativeTime
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
omittedField :: Maybe RelativeTime
$comittedField :: Maybe RelativeTime
parseJSONList :: Value -> Parser [RelativeTime]
$cparseJSONList :: Value -> Parser [RelativeTime]
parseJSON :: Value -> Parser RelativeTime
$cparseJSON :: Value -> Parser RelativeTime
FromJSON)

instance ToCBOR RelativeTime where
  toCBOR :: RelativeTime -> Encoding
toCBOR = forall a. ToCBOR a => a -> Encoding
toCBOR forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Pico
nominalDiffTimeToSeconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativeTime -> NominalDiffTime
getRelativeTime

instance FromCBOR RelativeTime where
  fromCBOR :: forall s. Decoder s RelativeTime
fromCBOR = NominalDiffTime -> RelativeTime
RelativeTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pico -> NominalDiffTime
secondsToNominalDiffTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. FromCBOR a => Decoder s a
fromCBOR

instance Serialise RelativeTime where
  encode :: RelativeTime -> Encoding
encode = forall a. ToCBOR a => a -> Encoding
toCBOR
  decode :: forall s. Decoder s RelativeTime
decode = forall a s. FromCBOR a => Decoder s a
fromCBOR

addRelativeTime :: NominalDiffTime -> RelativeTime -> RelativeTime
addRelativeTime :: NominalDiffTime -> RelativeTime -> RelativeTime
addRelativeTime NominalDiffTime
delta (RelativeTime NominalDiffTime
t) = NominalDiffTime -> RelativeTime
RelativeTime (NominalDiffTime
t forall a. Num a => a -> a -> a
+ NominalDiffTime
delta)

diffRelativeTime :: RelativeTime -> RelativeTime -> NominalDiffTime
diffRelativeTime :: RelativeTime -> RelativeTime -> NominalDiffTime
diffRelativeTime (RelativeTime NominalDiffTime
t) (RelativeTime NominalDiffTime
t') = NominalDiffTime
t forall a. Num a => a -> a -> a
- NominalDiffTime
t'

toRelativeTime :: SystemStart -> UTCTime -> RelativeTime
toRelativeTime :: SystemStart -> UTCTime -> RelativeTime
toRelativeTime (SystemStart UTCTime
t) UTCTime
t' =
  forall a. (?callStack::CallStack) => Bool -> a -> a
assert (UTCTime
t' forall a. Ord a => a -> a -> Bool
>= UTCTime
t) forall a b. (a -> b) -> a -> b
$
    NominalDiffTime -> RelativeTime
RelativeTime (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t' UTCTime
t)

fromRelativeTime :: SystemStart -> RelativeTime -> UTCTime
fromRelativeTime :: SystemStart -> RelativeTime -> UTCTime
fromRelativeTime (SystemStart UTCTime
t) (RelativeTime NominalDiffTime
t') = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
t' UTCTime
t

multRelativeTime :: Integral f => RelativeTime -> f -> RelativeTime
multRelativeTime :: forall f. Integral f => RelativeTime -> f -> RelativeTime
multRelativeTime (RelativeTime NominalDiffTime
t) =
  NominalDiffTime -> RelativeTime
RelativeTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f. Integral f => NominalDiffTime -> f -> NominalDiffTime
multNominalDiffTime NominalDiffTime
t

multNominalDiffTime :: Integral f => NominalDiffTime -> f -> NominalDiffTime
multNominalDiffTime :: forall f. Integral f => NominalDiffTime -> f -> NominalDiffTime
multNominalDiffTime NominalDiffTime
t f
f =
  Pico -> NominalDiffTime
secondsToNominalDiffTime forall a b. (a -> b) -> a -> b
$
    NominalDiffTime -> Pico
nominalDiffTimeToSeconds NominalDiffTime
t forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral f
f

{-------------------------------------------------------------------------------
  SlotLength
-------------------------------------------------------------------------------}

-- | Slot length
--
-- Precision is in milliseconds
newtype SlotLength = SlotLength {SlotLength -> NominalDiffTime
getSlotLength :: NominalDiffTime}
  deriving (SlotLength -> SlotLength -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlotLength -> SlotLength -> Bool
$c/= :: SlotLength -> SlotLength -> Bool
== :: SlotLength -> SlotLength -> Bool
$c== :: SlotLength -> SlotLength -> Bool
Eq, forall x. Rep SlotLength x -> SlotLength
forall x. SlotLength -> Rep SlotLength x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SlotLength x -> SlotLength
$cfrom :: forall x. SlotLength -> Rep SlotLength x
Generic, Context -> SlotLength -> IO (Maybe ThunkInfo)
Proxy SlotLength -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy SlotLength -> String
$cshowTypeOf :: Proxy SlotLength -> String
wNoThunks :: Context -> SlotLength -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> SlotLength -> IO (Maybe ThunkInfo)
noThunks :: Context -> SlotLength -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> SlotLength -> IO (Maybe ThunkInfo)
NoThunks)
  deriving (Int -> SlotLength -> ShowS
[SlotLength] -> ShowS
SlotLength -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SlotLength] -> ShowS
$cshowList :: [SlotLength] -> ShowS
show :: SlotLength -> String
$cshow :: SlotLength -> String
showsPrec :: Int -> SlotLength -> ShowS
$cshowsPrec :: Int -> SlotLength -> ShowS
Show) via Quiet SlotLength

instance ToCBOR SlotLength where
  toCBOR :: SlotLength -> Encoding
toCBOR = forall a. ToCBOR a => a -> Encoding
toCBOR forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotLength -> Integer
slotLengthToMillisec

instance FromCBOR SlotLength where
  fromCBOR :: forall s. Decoder s SlotLength
fromCBOR = Integer -> SlotLength
slotLengthFromMillisec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. FromCBOR a => Decoder s a
fromCBOR

instance Serialise SlotLength where
  encode :: SlotLength -> Encoding
encode = forall a. ToCBOR a => a -> Encoding
toCBOR
  decode :: forall s. Decoder s SlotLength
decode = forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | Constructor for 'SlotLength'
mkSlotLength :: NominalDiffTime -> SlotLength
mkSlotLength :: NominalDiffTime -> SlotLength
mkSlotLength = NominalDiffTime -> SlotLength
SlotLength

slotLengthFromSec :: Integer -> SlotLength
slotLengthFromSec :: Integer -> SlotLength
slotLengthFromSec = Integer -> SlotLength
slotLengthFromMillisec forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* Integer
1000)

slotLengthToSec :: SlotLength -> Integer
slotLengthToSec :: SlotLength -> Integer
slotLengthToSec = (forall a. Integral a => a -> a -> a
`div` Integer
1000) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotLength -> Integer
slotLengthToMillisec

slotLengthFromMillisec :: Integer -> SlotLength
slotLengthFromMillisec :: Integer -> SlotLength
slotLengthFromMillisec = NominalDiffTime -> SlotLength
mkSlotLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> NominalDiffTime
conv
  where
    -- Explicit type annotation here means that /if/ we change the precision,
    -- we are forced to reconsider this code.
    conv :: Integer -> NominalDiffTime
    conv :: Integer -> NominalDiffTime
conv =
      (forall a b. (Real a, Fractional b) => a -> b
realToFrac :: Pico -> NominalDiffTime)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => a -> a -> a
/ Pico
1000)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => Integer -> a
fromInteger :: Integer -> Pico)

slotLengthToMillisec :: SlotLength -> Integer
slotLengthToMillisec :: SlotLength -> Integer
slotLengthToMillisec = NominalDiffTime -> Integer
conv forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotLength -> NominalDiffTime
getSlotLength
  where
    -- Explicit type annotation here means that /if/ we change the precision,
    -- we are forced to reconsider this code.
    conv :: NominalDiffTime -> Integer
    conv :: NominalDiffTime -> Integer
conv =
      forall a b. (RealFrac a, Integral b) => a -> b
truncate
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* Pico
1000)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (Real a, Fractional b) => a -> b
realToFrac :: NominalDiffTime -> Pico)