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

module Ouroboros.Consensus.BlockchainTime.WallClock.Types (
    -- * System time
    SystemStart(..)
    -- * Relative time
  , RelativeTime(..)
  , addRelTime
  , diffRelTime
  , toRelativeTime
  , fromRelativeTime
    -- * Get current time (as 'RelativeTime')
  , SystemTime(..)
    -- * Slot length
  , SlotLength -- Opaque
  , getSlotLength
  , mkSlotLength
    -- ** Conversions
  , slotLengthFromSec
  , slotLengthToSec
  , slotLengthFromMillisec
  , slotLengthToMillisec
  ) where

import           Codec.Serialise
import           Control.Exception (assert)
import           Data.Fixed
import           Data.Time (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime)
import           GHC.Generics (Generic)
import           NoThunks.Class (InspectHeap (..), NoThunks,
                     OnlyCheckWhnfNamed (..))
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

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

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

diffRelTime :: RelativeTime -> RelativeTime -> NominalDiffTime
diffRelTime :: RelativeTime -> RelativeTime -> NominalDiffTime
diffRelTime (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

{-------------------------------------------------------------------------------
  Get current time (as RelativeTime)
-------------------------------------------------------------------------------}

-- | System time
--
-- Slots are counted from the system start.
data SystemTime m = SystemTime {
      -- | Get current time (as a 'RelativeTime')
      --
      -- For real deployment, this will take the current 'UTCTime' and then
      -- subtract the 'SystemStart' (see 'defaultSystemTime'). Tests don't
      -- bother with a 'UTCTime' and just work entirely in 'RelativeTime'.
      SystemTime m -> m RelativeTime
systemTimeCurrent :: m RelativeTime

      -- | Wait for 'SystemStart'
      --
      -- For the real deployment, this waits for the current 'UTCTime'
      -- to reach 'SystemStart'. In tests this does nothing.
    , SystemTime m -> m ()
systemTimeWait    :: m ()
    }
  deriving Context -> SystemTime m -> IO (Maybe ThunkInfo)
Proxy (SystemTime m) -> String
(Context -> SystemTime m -> IO (Maybe ThunkInfo))
-> (Context -> SystemTime m -> IO (Maybe ThunkInfo))
-> (Proxy (SystemTime m) -> String)
-> NoThunks (SystemTime m)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *).
Context -> SystemTime m -> IO (Maybe ThunkInfo)
forall (m :: * -> *). Proxy (SystemTime m) -> String
showTypeOf :: Proxy (SystemTime m) -> String
$cshowTypeOf :: forall (m :: * -> *). Proxy (SystemTime m) -> String
wNoThunks :: Context -> SystemTime m -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *).
Context -> SystemTime m -> IO (Maybe ThunkInfo)
noThunks :: Context -> SystemTime m -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (m :: * -> *).
Context -> SystemTime m -> IO (Maybe ThunkInfo)
NoThunks via OnlyCheckWhnfNamed "SystemTime" (SystemTime m)

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