New validity range tweaks and new utxo filters over values

CHANGELOG.md

@@ -31,6 +31,10 @@
 - API now exposes: `Cooked.Tweak.ValidityRange`, `interpretAndRun`, 
   `interpretAndRunWith`, `runTweak`, `runTweakFrom` and `datumHijackingTarget`
 - `there` modifier to apply a tweak at a precise place in a trace
+- New tweaks to change the start or end of the transaction validity range:
+  `setValidityStartTweak` and `setValidityEndTweak`
+- UTxo searches with predicates over values, including only ada, or not only ada:
+  `filterWithValuePred`, `filterWithOnlyAda` and `filterWithNotOnlyAda`
 
 ### Removed
 

src/Cooked/MockChain/UtxoSearch.hs

@@ -14,6 +14,9 @@ module Cooked.MockChain.UtxoSearch
     filterWithPure,
     filterWithOptic,
     filterWithPred,
+    filterWithValuePred,
+    filterWithOnlyAda,
+    filterWithNotOnlyAda,
   )
 where
 
@@ -23,6 +26,7 @@ import qualified Ledger.Tx as Ledger
 import ListT (ListT (..))
 import qualified ListT
 import Optics.Core
+import qualified Plutus.Script.Utils.Value as Pl2
 import qualified Plutus.V2.Ledger.Api as Pl2
 
 -- * The type of UTxO searches
@@ -91,3 +95,13 @@ filterWithOptic as optic = filterWithPure as (^? optic)
 
 filterWithPred :: Monad m => UtxoSearch m a -> (a -> Bool) -> UtxoSearch m a
 filterWithPred as f = filterWithPure as $ \a -> if f a then Just a else Nothing
+
+filterWithValuePred :: Monad m => UtxoSearch m Pl2.TxOut -> (Pl2.Value -> Bool) -> UtxoSearch m Pl2.Value
+filterWithValuePred as p = filterWithPure as $
+  \txOut -> let val = Pl2.txOutValue txOut in if p val then Just val else Nothing
+
+filterWithOnlyAda :: Monad m => UtxoSearch m Pl2.TxOut -> UtxoSearch m Pl2.Value
+filterWithOnlyAda as = filterWithValuePred as $ (1 ==) . length . Pl2.flattenValue
+
+filterWithNotOnlyAda :: Monad m => UtxoSearch m Pl2.TxOut -> UtxoSearch m Pl2.Value
+filterWithNotOnlyAda as = filterWithValuePred as $ (1 <) . length . Pl2.flattenValue

src/Cooked/Tweak/ValidityRange.hs

@@ -5,9 +5,9 @@ import Control.Monad (guard, void)
 import Cooked.MockChain (awaitSlot, currentSlot)
 import Cooked.Skeleton (txSkelValidityRangeL)
 import Cooked.Tweak.Common (MonadTweak, setTweak, viewTweak)
+import Ledger (before, contains, intersection, interval, isEmpty, member, never, singleton)
 import Ledger.Slot (Slot (Slot), SlotRange)
-import Plutus.V1.Ledger.Interval (before, contains, intersection, interval, isEmpty, member, never, singleton)
-import Plutus.V2.Ledger.Api (Extended (Finite), LowerBound (LowerBound), always, ivFrom)
+import Plutus.V2.Ledger.Api (Extended (Finite), Interval (..), LowerBound (..), UpperBound (..), always)
 
 getValidityRangeTweak :: MonadTweak m => m SlotRange
 getValidityRangeTweak = viewTweak txSkelValidityRangeL
@@ -23,6 +23,14 @@ setValidityRangeTweak newRange = do
 setAlwaysValidRangeTweak :: MonadTweak m => m SlotRange
 setAlwaysValidRangeTweak = setValidityRangeTweak always
 
+-- | Sets the left bound of the validity range. Leaves the right bound unchanged
+setValidityStartTweak :: MonadTweak m => Slot -> m SlotRange
+setValidityStartTweak left = getValidityRangeTweak >>= setValidityRangeTweak . Interval (LowerBound (Finite left) True) . ivTo
+
+-- | Sets the right bound of the validity range. Leaves the left bound unchanged
+setValidityEndTweak :: MonadTweak m => Slot -> m SlotRange
+setValidityEndTweak right = getValidityRangeTweak >>= setValidityRangeTweak . flip Interval (UpperBound (Finite right) True) . ivFrom
+
 -- | Checks if the validity range satisfies a certain predicate
 validityRangeSatisfiesTweak :: MonadTweak m => (SlotRange -> Bool) -> m Bool
 validityRangeSatisfiesTweak = (<$> getValidityRangeTweak)