-- | This module defines 'Tweak's revolving around the validity range of a
-- transaction
module Cooked.Tweak.ValidityRange
  ( getValidityRangeTweak,
    setValidityRangeTweak,
    setAlwaysValidRangeTweak,
    setValidityStartTweak,
    setValidityEndTweak,
    validityRangeSatisfiesTweak,
    isValidAtTweak,
    isValidNowTweak,
    isValidDuringTweak,
    hasEmptyTimeRangeTweak,
    hasFullTimeRangeTweak,
    intersectValidityRangeTweak,
    centerAroundValidityRangeTweak,
    makeValidityRangeSingletonTweak,
    makeValidityRangeNowTweak,
  )
where

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

-- | Looks up the current validity range of the transaction
getValidityRangeTweak ::
  (Member Tweak effs) =>
  Sem effs Ledger.SlotRange
getValidityRangeTweak :: forall (effs :: EffectRow). Member Tweak effs => Sem effs SlotRange
getValidityRangeTweak = Optic' A_Lens NoIx TxSkel SlotRange -> Sem effs SlotRange
forall (effs :: EffectRow) (k :: OpticKind) (is :: IxList)
       (a :: OpticKind).
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak Optic' A_Lens NoIx TxSkel SlotRange
txSkelValidityRangeL

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

-- | Ensures the skeleton makes for an unconstrained validity range
setAlwaysValidRangeTweak ::
  (Member Tweak effs) =>
  Sem effs Ledger.SlotRange
setAlwaysValidRangeTweak :: forall (effs :: EffectRow). Member Tweak effs => Sem effs SlotRange
setAlwaysValidRangeTweak = SlotRange -> Sem effs SlotRange
forall (effs :: EffectRow).
Member Tweak effs =>
SlotRange -> Sem effs SlotRange
setValidityRangeTweak SlotRange
forall (a :: OpticKind). Interval a
Api.always

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

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

-- | Checks if the validity range satisfies a certain predicate
validityRangeSatisfiesTweak ::
  (Member Tweak effs) =>
  (Ledger.SlotRange -> Bool) ->
  Sem effs Bool
validityRangeSatisfiesTweak :: forall (effs :: EffectRow).
Member Tweak effs =>
(SlotRange -> Closure) -> Sem effs Closure
validityRangeSatisfiesTweak = ((SlotRange -> Closure) -> Sem effs SlotRange -> Sem effs Closure
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> Sem effs SlotRange
forall (effs :: EffectRow). Member Tweak effs => Sem effs SlotRange
getValidityRangeTweak)

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

-- | Checks if the current validity range includes the current time
isValidNowTweak ::
  (Members '[Tweak, MockChainRead] effs) =>
  Sem effs Bool
isValidNowTweak :: forall (effs :: EffectRow).
Members '[Tweak, MockChainRead] effs =>
Sem effs Closure
isValidNowTweak = Sem effs Slot
forall (effs :: EffectRow).
Member MockChainRead effs =>
Sem effs Slot
currentSlot Sem effs Slot -> (Slot -> Sem effs Closure) -> Sem effs Closure
forall (a :: OpticKind) (b :: OpticKind).
Sem effs a -> (a -> Sem effs b) -> Sem effs b
forall (m :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Monad m =>
m a -> (a -> m b) -> m b
>>= Slot -> Sem effs Closure
forall (effs :: EffectRow).
Member Tweak effs =>
Slot -> Sem effs Closure
isValidAtTweak

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

-- | Checks if the validity range is empty
hasEmptyTimeRangeTweak ::
  (Member Tweak effs) =>
  Sem effs Bool
hasEmptyTimeRangeTweak :: forall (effs :: EffectRow). Member Tweak effs => Sem effs Closure
hasEmptyTimeRangeTweak = (SlotRange -> Closure) -> Sem effs Closure
forall (effs :: EffectRow).
Member Tweak effs =>
(SlotRange -> Closure) -> Sem effs Closure
validityRangeSatisfiesTweak SlotRange -> Closure
forall (a :: OpticKind). (Enum a, Ord a) => Interval a -> Closure
Api.isEmpty

-- | Checks if the validity range is unconstrained
hasFullTimeRangeTweak ::
  (Member Tweak effs) =>
  Sem effs Bool
hasFullTimeRangeTweak :: forall (effs :: EffectRow). Member Tweak effs => Sem effs Closure
hasFullTimeRangeTweak = (SlotRange -> Closure) -> Sem effs Closure
forall (effs :: EffectRow).
Member Tweak effs =>
(SlotRange -> Closure) -> Sem effs Closure
validityRangeSatisfiesTweak (SlotRange
forall (a :: OpticKind). Interval a
Api.always SlotRange -> SlotRange -> Closure
forall (a :: OpticKind). 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 ::
  (Members '[Tweak, NonDet] effs) =>
  Ledger.SlotRange ->
  Sem effs Ledger.SlotRange
intersectValidityRangeTweak :: forall (effs :: EffectRow).
Members '[Tweak, NonDet] effs =>
SlotRange -> Sem effs SlotRange
intersectValidityRangeTweak SlotRange
newRange = do
  SlotRange
oldRange <- Optic' A_Lens NoIx TxSkel SlotRange -> Sem effs SlotRange
forall (effs :: EffectRow) (k :: OpticKind) (is :: IxList)
       (a :: OpticKind).
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak Optic' A_Lens NoIx TxSkel SlotRange
txSkelValidityRangeL
  let combinedRange :: SlotRange
combinedRange = SlotRange -> SlotRange -> SlotRange
forall (a :: OpticKind).
(Enum a, Ord a) =>
Interval a -> Interval a -> Interval a
Api.intersection SlotRange
newRange SlotRange
oldRange
  Closure -> Sem effs ()
forall (f :: OpticKind -> OpticKind).
Alternative f =>
Closure -> f ()
guard (SlotRange
combinedRange SlotRange -> SlotRange -> Closure
forall (a :: OpticKind). Eq a => a -> a -> Closure
/= SlotRange
forall (a :: OpticKind). Interval a
Api.never)
  Optic' A_Lens NoIx TxSkel SlotRange -> SlotRange -> Sem effs ()
forall (effs :: EffectRow) (k :: OpticKind) (is :: IxList)
       (a :: OpticKind).
(Member Tweak effs, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> Sem effs ()
setTweak Optic' A_Lens NoIx TxSkel SlotRange
txSkelValidityRangeL SlotRange
combinedRange
  SlotRange -> Sem effs SlotRange
forall (a :: OpticKind). a -> Sem effs a
forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
Monad m =>
a -> m a
return SlotRange
oldRange

-- | Centers the validity range around a value with a certain radius
centerAroundValidityRangeTweak ::
  (Member Tweak effs) =>
  Ledger.Slot ->
  Integer ->
  Sem effs Ledger.SlotRange
centerAroundValidityRangeTweak :: forall (effs :: EffectRow).
Member Tweak effs =>
Slot -> Integer -> Sem effs SlotRange
centerAroundValidityRangeTweak Slot
t (Integer -> Slot
Ledger.Slot -> Slot
radius) = do
  SlotRange -> Sem effs SlotRange
forall (effs :: EffectRow).
Member Tweak effs =>
SlotRange -> Sem effs SlotRange
setValidityRangeTweak (SlotRange -> Sem effs SlotRange)
-> SlotRange -> Sem effs SlotRange
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Slot -> Slot -> SlotRange
forall (a :: OpticKind). a -> a -> Interval a
Api.interval (Slot
t Slot -> Slot -> Slot
forall (a :: OpticKind). Num a => a -> a -> a
- Slot
radius) (Slot
t Slot -> Slot -> Slot
forall (a :: OpticKind). Num a => a -> a -> a
+ Slot
radius)

-- | Makes a transaction range equal to a singleton
makeValidityRangeSingletonTweak ::
  (Member Tweak effs) =>
  Ledger.Slot ->
  Sem effs Ledger.SlotRange
makeValidityRangeSingletonTweak :: forall (effs :: EffectRow).
Member Tweak effs =>
Slot -> Sem effs SlotRange
makeValidityRangeSingletonTweak = SlotRange -> Sem effs SlotRange
forall (effs :: EffectRow).
Member Tweak effs =>
SlotRange -> Sem effs SlotRange
setValidityRangeTweak (SlotRange -> Sem effs SlotRange)
-> (Slot -> SlotRange) -> Slot -> Sem effs SlotRange
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. Slot -> SlotRange
forall (a :: OpticKind). a -> Interval a
Api.singleton

-- | Makes the transaction validity range comply with the current time
makeValidityRangeNowTweak ::
  (Members '[Tweak, MockChainRead] effs) =>
  Sem effs Ledger.SlotRange
makeValidityRangeNowTweak :: forall (effs :: EffectRow).
Members '[Tweak, MockChainRead] effs =>
Sem effs SlotRange
makeValidityRangeNowTweak = Sem effs Slot
forall (effs :: EffectRow).
Member MockChainRead effs =>
Sem effs Slot
currentSlot Sem effs Slot -> (Slot -> Sem effs SlotRange) -> Sem effs SlotRange
forall (a :: OpticKind) (b :: OpticKind).
Sem effs a -> (a -> Sem effs b) -> Sem effs b
forall (m :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Monad m =>
m a -> (a -> m b) -> m b
>>= Slot -> Sem effs SlotRange
forall (effs :: EffectRow).
Member Tweak effs =>
Slot -> Sem effs SlotRange
makeValidityRangeSingletonTweak