-- | This module defines 'Tweaks' revolving around the validity range of a
-- transaction
module Cooked.Tweak.ValidityRange where

import Control.Monad
import Cooked.MockChain
import Cooked.Skeleton
import Cooked.Tweak.Common
import Ledger.Slot qualified as Ledger
import PlutusLedgerApi.V1.Interval qualified as Api

getValidityRangeTweak :: (MonadTweak m) => m Ledger.SlotRange
getValidityRangeTweak :: forall (m :: * -> *). MonadTweak m => m SlotRange
getValidityRangeTweak = Optic' A_Lens NoIx TxSkel SlotRange -> m SlotRange
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Getter) =>
Optic' k is TxSkel a -> m a
viewTweak Optic' A_Lens NoIx TxSkel SlotRange
txSkelValidityRangeL

-- | Changes the current validity range, returning the old one
setValidityRangeTweak :: (MonadTweak m) => Ledger.SlotRange -> m Ledger.SlotRange
setValidityRangeTweak :: forall (m :: * -> *). MonadTweak m => SlotRange -> m SlotRange
setValidityRangeTweak SlotRange
newRange = do
  SlotRange
oldRange <- m SlotRange
forall (m :: * -> *). MonadTweak m => m SlotRange
getValidityRangeTweak
  Optic' A_Lens NoIx TxSkel SlotRange -> SlotRange -> m ()
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> m ()
setTweak Optic' A_Lens NoIx TxSkel SlotRange
txSkelValidityRangeL SlotRange
newRange
  SlotRange -> m SlotRange
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return SlotRange
oldRange

-- | Ensures the skeleton makes for an unconstrained validity range
setAlwaysValidRangeTweak :: (MonadTweak m) => m Ledger.SlotRange
setAlwaysValidRangeTweak :: forall (m :: * -> *). MonadTweak m => m SlotRange
setAlwaysValidRangeTweak = SlotRange -> m SlotRange
forall (m :: * -> *). MonadTweak m => SlotRange -> m SlotRange
setValidityRangeTweak SlotRange
forall a. Interval a
Api.always

-- | Sets the left bound of the validity range. Leaves the right bound unchanged
setValidityStartTweak :: (MonadTweak m) => Ledger.Slot -> m Ledger.SlotRange
setValidityStartTweak :: forall (m :: * -> *). MonadTweak m => Slot -> m SlotRange
setValidityStartTweak Slot
left = m SlotRange
forall (m :: * -> *). MonadTweak m => m SlotRange
getValidityRangeTweak m SlotRange -> (SlotRange -> m SlotRange) -> m SlotRange
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SlotRange -> m SlotRange
forall (m :: * -> *). MonadTweak m => SlotRange -> m SlotRange
setValidityRangeTweak (SlotRange -> m SlotRange)
-> (SlotRange -> SlotRange) -> SlotRange -> m SlotRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LowerBound Slot -> UpperBound Slot -> SlotRange
forall a. LowerBound a -> UpperBound a -> Interval a
Api.Interval (Extended Slot -> Closure -> LowerBound Slot
forall a. Extended a -> Closure -> LowerBound a
Api.LowerBound (Slot -> Extended Slot
forall a. a -> Extended a
Api.Finite Slot
left) Closure
True) (UpperBound Slot -> SlotRange)
-> (SlotRange -> UpperBound Slot) -> SlotRange -> SlotRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotRange -> UpperBound Slot
forall a. Interval a -> UpperBound a
Api.ivTo

-- | Sets the right bound of the validity range. Leaves the left bound unchanged
setValidityEndTweak :: (MonadTweak m) => Ledger.Slot -> m Ledger.SlotRange
setValidityEndTweak :: forall (m :: * -> *). MonadTweak m => Slot -> m SlotRange
setValidityEndTweak Slot
right = m SlotRange
forall (m :: * -> *). MonadTweak m => m SlotRange
getValidityRangeTweak m SlotRange -> (SlotRange -> m SlotRange) -> m SlotRange
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SlotRange -> m SlotRange
forall (m :: * -> *). MonadTweak m => SlotRange -> m SlotRange
setValidityRangeTweak (SlotRange -> m SlotRange)
-> (SlotRange -> SlotRange) -> SlotRange -> m SlotRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LowerBound Slot -> UpperBound Slot -> SlotRange)
-> UpperBound Slot -> LowerBound Slot -> SlotRange
forall a b c. (a -> b -> c) -> b -> a -> c
flip LowerBound Slot -> UpperBound Slot -> SlotRange
forall a. LowerBound a -> UpperBound a -> Interval a
Api.Interval (Extended Slot -> Closure -> UpperBound Slot
forall a. Extended a -> Closure -> UpperBound a
Api.UpperBound (Slot -> Extended Slot
forall a. a -> Extended a
Api.Finite Slot
right) Closure
True) (LowerBound Slot -> SlotRange)
-> (SlotRange -> LowerBound Slot) -> SlotRange -> SlotRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotRange -> LowerBound Slot
forall a. Interval a -> LowerBound a
Api.ivFrom

-- | Checks if the validity range satisfies a certain predicate
validityRangeSatisfiesTweak :: (MonadTweak m) => (Ledger.SlotRange -> Bool) -> m Bool
validityRangeSatisfiesTweak :: forall (m :: * -> *).
MonadTweak m =>
(SlotRange -> Closure) -> m Closure
validityRangeSatisfiesTweak = ((SlotRange -> Closure) -> m SlotRange -> m Closure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m SlotRange
forall (m :: * -> *). MonadTweak m => m SlotRange
getValidityRangeTweak)

-- | Checks if a given time belongs to the validity range of a transaction
isValidAtTweak :: (MonadTweak m) => Ledger.Slot -> m Bool
isValidAtTweak :: forall (m :: * -> *). MonadTweak m => Slot -> m Closure
isValidAtTweak = (SlotRange -> Closure) -> m Closure
forall (m :: * -> *).
MonadTweak m =>
(SlotRange -> Closure) -> m Closure
validityRangeSatisfiesTweak ((SlotRange -> Closure) -> m Closure)
-> (Slot -> SlotRange -> Closure) -> Slot -> m Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Slot -> SlotRange -> Closure
forall a. (Enum a, Ord a) => a -> Interval a -> Closure
Api.member

-- | Checks if the current validity range includes the current time
isValidNowTweak :: (MonadTweak m) => m Bool
isValidNowTweak :: forall (m :: * -> *). MonadTweak m => m Closure
isValidNowTweak = m Slot
forall (m :: * -> *). MonadBlockChainWithoutValidation m => m Slot
currentSlot m Slot -> (Slot -> m Closure) -> m Closure
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Slot -> m Closure
forall (m :: * -> *). MonadTweak m => Slot -> m Closure
isValidAtTweak

-- | Checks if a given range is included in the validity range of a transaction
isValidDuringTweak :: (MonadTweak m) => Ledger.SlotRange -> m Bool
isValidDuringTweak :: forall (m :: * -> *). MonadTweak m => SlotRange -> m Closure
isValidDuringTweak = (SlotRange -> Closure) -> m Closure
forall (m :: * -> *).
MonadTweak m =>
(SlotRange -> Closure) -> m Closure
validityRangeSatisfiesTweak ((SlotRange -> Closure) -> m Closure)
-> (SlotRange -> SlotRange -> Closure) -> SlotRange -> m Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotRange -> SlotRange -> Closure)
-> SlotRange -> SlotRange -> Closure
forall a b c. (a -> b -> c) -> b -> a -> c
flip SlotRange -> SlotRange -> Closure
forall a. (Enum a, Ord a) => Interval a -> Interval a -> Closure
Api.contains

-- | Checks if the validity range is empty
hasEmptyTimeRangeTweak :: (MonadTweak m) => m Bool
hasEmptyTimeRangeTweak :: forall (m :: * -> *). MonadTweak m => m Closure
hasEmptyTimeRangeTweak = (SlotRange -> Closure) -> m Closure
forall (m :: * -> *).
MonadTweak m =>
(SlotRange -> Closure) -> m Closure
validityRangeSatisfiesTweak SlotRange -> Closure
forall a. (Enum a, Ord a) => Interval a -> Closure
Api.isEmpty

-- | Checks if the validity range is unconstrained
hasFullTimeRangeTweak :: (MonadTweak m) => m Bool
hasFullTimeRangeTweak :: forall (m :: * -> *). MonadTweak m => m Closure
hasFullTimeRangeTweak = (SlotRange -> Closure) -> m Closure
forall (m :: * -> *).
MonadTweak m =>
(SlotRange -> Closure) -> m Closure
validityRangeSatisfiesTweak (SlotRange
forall a. Interval a
Api.always SlotRange -> SlotRange -> Closure
forall a. Eq a => a -> a -> Closure
==)

-- | Adds a constraint to the current validity range. Returns the old range, and
-- fails is the resulting interval is empty
intersectValidityRangeTweak :: (MonadTweak m) => Ledger.SlotRange -> m Ledger.SlotRange
intersectValidityRangeTweak :: forall (m :: * -> *). MonadTweak m => SlotRange -> m SlotRange
intersectValidityRangeTweak SlotRange
newRange = do
  SlotRange
oldRange <- Optic' A_Lens NoIx TxSkel SlotRange -> m SlotRange
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Getter) =>
Optic' k is TxSkel a -> m a
viewTweak Optic' A_Lens NoIx TxSkel SlotRange
txSkelValidityRangeL
  let combinedRange :: SlotRange
combinedRange = SlotRange -> SlotRange -> SlotRange
forall a. (Enum a, Ord a) => Interval a -> Interval a -> Interval a
Api.intersection SlotRange
newRange SlotRange
oldRange
  Closure -> m ()
forall (f :: * -> *). Alternative f => Closure -> f ()
guard (SlotRange
combinedRange SlotRange -> SlotRange -> Closure
forall a. Eq a => a -> a -> Closure
/= SlotRange
forall a. Interval a
Api.never)
  Optic' A_Lens NoIx TxSkel SlotRange -> SlotRange -> m ()
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> m ()
setTweak Optic' A_Lens NoIx TxSkel SlotRange
txSkelValidityRangeL SlotRange
combinedRange
  SlotRange -> m SlotRange
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return SlotRange
oldRange

-- | Centers the validity range around a value with a certain radius
centerAroundValidityRangeTweak :: (MonadTweak m) => Ledger.Slot -> Integer -> m Ledger.SlotRange
centerAroundValidityRangeTweak :: forall (m :: * -> *).
MonadTweak m =>
Slot -> Integer -> m SlotRange
centerAroundValidityRangeTweak Slot
t Integer
r = do
  let radius :: Slot
radius = Integer -> Slot
Ledger.Slot Integer
r
      left :: Slot
left = Slot
t Slot -> Slot -> Slot
forall a. Num a => a -> a -> a
- Slot
radius
      right :: Slot
right = Slot
t Slot -> Slot -> Slot
forall a. Num a => a -> a -> a
+ Slot
radius
      newRange :: SlotRange
newRange = Slot -> Slot -> SlotRange
forall a. a -> a -> Interval a
Api.interval Slot
left Slot
right
  SlotRange -> m SlotRange
forall (m :: * -> *). MonadTweak m => SlotRange -> m SlotRange
setValidityRangeTweak SlotRange
newRange

-- | Makes a transaction range equal to a singleton
makeValidityRangeSingletonTweak :: (MonadTweak m) => Ledger.Slot -> m Ledger.SlotRange
makeValidityRangeSingletonTweak :: forall (m :: * -> *). MonadTweak m => Slot -> m SlotRange
makeValidityRangeSingletonTweak = SlotRange -> m SlotRange
forall (m :: * -> *). MonadTweak m => SlotRange -> m SlotRange
setValidityRangeTweak (SlotRange -> m SlotRange)
-> (Slot -> SlotRange) -> Slot -> m SlotRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Slot -> SlotRange
forall a. a -> Interval a
Api.singleton

-- | Makes the transaction validity range comply with the current time
makeValidityRangeNowTweak :: (MonadTweak m) => m Ledger.SlotRange
makeValidityRangeNowTweak :: forall (m :: * -> *). MonadTweak m => m SlotRange
makeValidityRangeNowTweak = m Slot
forall (m :: * -> *). MonadBlockChainWithoutValidation m => m Slot
currentSlot m Slot -> (Slot -> m SlotRange) -> m SlotRange
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Slot -> m SlotRange
forall (m :: * -> *). MonadTweak m => Slot -> m SlotRange
makeValidityRangeSingletonTweak

-- | Makes current time comply with the validity range of the transaction under
-- modification. Returns the new current time after the modification; fails if
-- current time is already after the validity range.
waitUntilValidTweak :: (MonadTweak m) => m Ledger.Slot
waitUntilValidTweak :: forall (m :: * -> *). MonadTweak m => m Slot
waitUntilValidTweak = do
  Slot
now <- m Slot
forall (m :: * -> *). MonadBlockChainWithoutValidation m => m Slot
currentSlot
  SlotRange
vRange <- m SlotRange
forall (m :: * -> *). MonadTweak m => m SlotRange
getValidityRangeTweak
  if Slot -> SlotRange -> Closure
forall a. (Enum a, Ord a) => a -> Interval a -> Closure
Api.member Slot
now SlotRange
vRange
    then Slot -> m Slot
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Slot
now
    else do
      Closure -> m ()
forall (f :: * -> *). Alternative f => Closure -> f ()
guard (Closure -> m ()) -> Closure -> m ()
forall a b. (a -> b) -> a -> b
$ Slot -> SlotRange -> Closure
forall a. (Enum a, Ord a) => a -> Interval a -> Closure
Api.before Slot
now SlotRange
vRange
      Closure -> m ()
forall (f :: * -> *). Alternative f => Closure -> f ()
guard (Closure -> m ()) -> Closure -> m ()
forall a b. (a -> b) -> a -> b
$ Closure -> Closure
not (Closure -> Closure) -> Closure -> Closure
forall a b. (a -> b) -> a -> b
$ SlotRange -> Closure
forall a. (Enum a, Ord a) => Interval a -> Closure
Api.isEmpty SlotRange
vRange
      Slot
later <- case SlotRange -> LowerBound Slot
forall a. Interval a -> LowerBound a
Api.ivFrom SlotRange
vRange of
        Api.LowerBound (Api.Finite Slot
left) Closure
isClosed ->
          Slot -> m Slot
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Slot -> m Slot) -> Slot -> m Slot
forall a b. (a -> b) -> a -> b
$ Slot
left Slot -> Slot -> Slot
forall a. Num a => a -> a -> a
+ Integer -> Slot
Ledger.Slot (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Closure -> Int
forall a. Enum a => a -> Int
fromEnum (Closure -> Int) -> Closure -> Int
forall a b. (a -> b) -> a -> b
$ Closure -> Closure
not Closure
isClosed)
        LowerBound Slot
_ -> [Char] -> m Slot
forall a. HasCallStack => [Char] -> a
error [Char]
"this should never happen: left-finite interval without left border"
      m Slot -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Slot -> m ()) -> m Slot -> m ()
forall a b. (a -> b) -> a -> b
$ Slot -> m Slot
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
Slot -> m Slot
awaitSlot Slot
later
      Slot -> m Slot
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Slot
later