{-# 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.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
(SystemStart -> SystemStart -> Bool)
-> (SystemStart -> SystemStart -> Bool) -> Eq SystemStart
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. SystemStart -> Rep SystemStart x)
-> (forall x. Rep SystemStart x -> SystemStart)
-> Generic SystemStart
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
(Context -> SystemStart -> IO (Maybe ThunkInfo))
-> (Context -> SystemStart -> IO (Maybe ThunkInfo))
-> (Proxy SystemStart -> String)
-> NoThunks SystemStart
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
(Int -> SystemStart -> ShowS)
-> (SystemStart -> String)
-> ([SystemStart] -> ShowS)
-> Show SystemStart
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 Decoder s SystemStart
Decoder s [SystemStart]
[SystemStart] -> Encoding
SystemStart -> Encoding
(SystemStart -> Encoding)
-> (forall s. Decoder s SystemStart)
-> ([SystemStart] -> Encoding)
-> (forall s. Decoder s [SystemStart])
-> Serialise SystemStart
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 :: Decoder s [SystemStart]
$cdecodeList :: forall s. Decoder s [SystemStart]
encodeList :: [SystemStart] -> Encoding
$cencodeList :: [SystemStart] -> Encoding
decode :: Decoder s SystemStart
$cdecode :: forall s. Decoder s SystemStart
encode :: SystemStart -> Encoding
$cencode :: SystemStart -> Encoding
Serialise
  deriving newtype (Typeable SystemStart
Typeable SystemStart
-> (SystemStart -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy SystemStart -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy [SystemStart] -> Size)
-> ToCBOR 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
$cp1ToCBOR :: Typeable SystemStart
ToCBOR, Typeable SystemStart
Decoder s SystemStart
Typeable SystemStart
-> (forall s. Decoder s SystemStart)
-> (Proxy SystemStart -> Text)
-> FromCBOR 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 :: Decoder s SystemStart
$cfromCBOR :: forall s. Decoder s SystemStart
$cp1FromCBOR :: Typeable SystemStart
FromCBOR)

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

-- | 'RelativeTime' is time relative to the 'SystemStart'
newtype RelativeTime = RelativeTime { RelativeTime -> NominalDiffTime
getRelativeTime :: NominalDiffTime }
  deriving stock   (RelativeTime -> RelativeTime -> Bool
(RelativeTime -> RelativeTime -> Bool)
-> (RelativeTime -> RelativeTime -> Bool) -> Eq RelativeTime
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
Eq RelativeTime
-> (RelativeTime -> RelativeTime -> Ordering)
-> (RelativeTime -> RelativeTime -> Bool)
-> (RelativeTime -> RelativeTime -> Bool)
-> (RelativeTime -> RelativeTime -> Bool)
-> (RelativeTime -> RelativeTime -> Bool)
-> (RelativeTime -> RelativeTime -> RelativeTime)
-> (RelativeTime -> RelativeTime -> RelativeTime)
-> Ord 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
$cp1Ord :: Eq RelativeTime
Ord, (forall x. RelativeTime -> Rep RelativeTime x)
-> (forall x. Rep RelativeTime x -> RelativeTime)
-> Generic RelativeTime
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
(Context -> RelativeTime -> IO (Maybe ThunkInfo))
-> (Context -> RelativeTime -> IO (Maybe ThunkInfo))
-> (Proxy RelativeTime -> String)
-> NoThunks RelativeTime
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
(Int -> RelativeTime -> ShowS)
-> (RelativeTime -> String)
-> ([RelativeTime] -> ShowS)
-> Show RelativeTime
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

addRelativeTime :: NominalDiffTime -> RelativeTime -> RelativeTime
addRelativeTime :: NominalDiffTime -> RelativeTime -> RelativeTime
addRelativeTime NominalDiffTime
delta (RelativeTime NominalDiffTime
t) = NominalDiffTime -> RelativeTime
RelativeTime (NominalDiffTime
t NominalDiffTime -> NominalDiffTime -> NominalDiffTime
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 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- NominalDiffTime
t'

toRelativeTime :: SystemStart -> UTCTime -> RelativeTime
toRelativeTime :: SystemStart -> UTCTime -> RelativeTime
toRelativeTime (SystemStart UTCTime
t) UTCTime
t' = Bool -> RelativeTime -> RelativeTime
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (UTCTime
t' UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
t) (RelativeTime -> RelativeTime) -> RelativeTime -> RelativeTime
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 :: RelativeTime -> f -> RelativeTime
multRelativeTime (RelativeTime NominalDiffTime
t) =
  NominalDiffTime -> RelativeTime
RelativeTime (NominalDiffTime -> RelativeTime)
-> (f -> NominalDiffTime) -> f -> RelativeTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> f -> NominalDiffTime
forall f. Integral f => NominalDiffTime -> f -> NominalDiffTime
multNominalDiffTime NominalDiffTime
t

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


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

-- | Slot length
newtype SlotLength = SlotLength { SlotLength -> NominalDiffTime
getSlotLength :: NominalDiffTime }
  deriving (SlotLength -> SlotLength -> Bool
(SlotLength -> SlotLength -> Bool)
-> (SlotLength -> SlotLength -> Bool) -> Eq SlotLength
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. SlotLength -> Rep SlotLength x)
-> (forall x. Rep SlotLength x -> SlotLength) -> Generic SlotLength
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
(Context -> SlotLength -> IO (Maybe ThunkInfo))
-> (Context -> SlotLength -> IO (Maybe ThunkInfo))
-> (Proxy SlotLength -> String)
-> NoThunks SlotLength
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
(Int -> SlotLength -> ShowS)
-> (SlotLength -> String)
-> ([SlotLength] -> ShowS)
-> Show SlotLength
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

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

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

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

slotLengthFromMillisec :: Integer -> SlotLength
slotLengthFromMillisec :: Integer -> SlotLength
slotLengthFromMillisec = NominalDiffTime -> SlotLength
mkSlotLength (NominalDiffTime -> SlotLength)
-> (Integer -> NominalDiffTime) -> Integer -> SlotLength
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 = (Pico -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac :: Pico -> NominalDiffTime)
         (Pico -> NominalDiffTime)
-> (Integer -> Pico) -> Integer -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pico -> Pico -> Pico
forall a. Fractional a => a -> a -> a
/ Pico
1000)
         (Pico -> Pico) -> (Integer -> Pico) -> Integer -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Pico
forall a. Num a => Integer -> a
fromInteger :: Integer -> Pico)

slotLengthToMillisec :: SlotLength -> Integer
slotLengthToMillisec :: SlotLength -> Integer
slotLengthToMillisec = NominalDiffTime -> Integer
conv (NominalDiffTime -> Integer)
-> (SlotLength -> NominalDiffTime) -> SlotLength -> Integer
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 = Pico -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate
         (Pico -> Integer)
-> (NominalDiffTime -> Pico) -> NominalDiffTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
* Pico
1000)
         (Pico -> Pico)
-> (NominalDiffTime -> Pico) -> NominalDiffTime -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NominalDiffTime -> Pico
forall a b. (Real a, Fractional b) => a -> b
realToFrac :: NominalDiffTime -> Pico)

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

instance Serialise RelativeTime where
  encode :: RelativeTime -> Encoding
encode = Pico -> Encoding
forall a. Serialise a => a -> Encoding
encode (Pico -> Encoding)
-> (RelativeTime -> Pico) -> RelativeTime -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Pico
toPico (NominalDiffTime -> Pico)
-> (RelativeTime -> NominalDiffTime) -> RelativeTime -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativeTime -> NominalDiffTime
getRelativeTime
    where
      toPico :: NominalDiffTime -> Pico
      toPico :: NominalDiffTime -> Pico
toPico = NominalDiffTime -> Pico
forall a b. (Real a, Fractional b) => a -> b
realToFrac

  decode :: Decoder s RelativeTime
decode = (NominalDiffTime -> RelativeTime
RelativeTime (NominalDiffTime -> RelativeTime)
-> (Pico -> NominalDiffTime) -> Pico -> RelativeTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pico -> NominalDiffTime
fromPico) (Pico -> RelativeTime) -> Decoder s Pico -> Decoder s RelativeTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Pico
forall a s. Serialise a => Decoder s a
decode
    where
      fromPico :: Pico -> NominalDiffTime
      fromPico :: Pico -> NominalDiffTime
fromPico = Pico -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac

instance Serialise SlotLength where
  encode :: SlotLength -> Encoding
encode = Integer -> Encoding
forall a. Serialise a => a -> Encoding
encode (Integer -> Encoding)
-> (SlotLength -> Integer) -> SlotLength -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotLength -> Integer
slotLengthToMillisec
  decode :: Decoder s SlotLength
decode = Integer -> SlotLength
slotLengthFromMillisec (Integer -> SlotLength)
-> Decoder s Integer -> Decoder s SlotLength
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall a s. Serialise a => Decoder s a
decode