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
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
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
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
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
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)
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
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
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
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
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
==)
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
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
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
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
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