module Cooked.Tweak.Outputs
( ensureOutputTweak,
addOutputTweak,
removeOutputTweak,
tamperDatumTweak,
TamperDatumLbl (..),
malformDatumTweak,
MalformDatumLbl (..),
)
where
import Control.Monad
import Cooked.Output
import Cooked.Pretty.Class
import Cooked.Skeleton
import Cooked.Tweak.Common
import Cooked.Tweak.Labels
import Data.List (partition)
import Data.Maybe
import Data.Typeable
import Optics.Core
import PlutusLedgerApi.V3 qualified as Api
ensureOutputTweak :: (MonadTweak m) => TxSkelOut -> m (Maybe TxSkelOut)
ensureOutputTweak :: forall (m :: * -> *).
MonadTweak m =>
TxSkelOut -> m (Maybe TxSkelOut)
ensureOutputTweak TxSkelOut
txSkelOut = do
[TxSkelOut]
presentOutputs <- Optic' A_Lens NoIx TxSkel [TxSkelOut] -> m [TxSkelOut]
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 [TxSkelOut]
txSkelOutsL
if TxSkelOut
txSkelOut TxSkelOut -> [TxSkelOut] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TxSkelOut]
presentOutputs
then Maybe TxSkelOut -> m (Maybe TxSkelOut)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TxSkelOut
forall a. Maybe a
Nothing
else do
TxSkelOut -> m ()
forall (m :: * -> *). MonadTweak m => TxSkelOut -> m ()
addOutputTweak TxSkelOut
txSkelOut
Maybe TxSkelOut -> m (Maybe TxSkelOut)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TxSkelOut -> m (Maybe TxSkelOut))
-> Maybe TxSkelOut -> m (Maybe TxSkelOut)
forall a b. (a -> b) -> a -> b
$ TxSkelOut -> Maybe TxSkelOut
forall a. a -> Maybe a
Just TxSkelOut
txSkelOut
addOutputTweak :: (MonadTweak m) => TxSkelOut -> m ()
addOutputTweak :: forall (m :: * -> *). MonadTweak m => TxSkelOut -> m ()
addOutputTweak TxSkelOut
txSkelOut = Optic' A_Lens NoIx TxSkel [TxSkelOut]
-> ([TxSkelOut] -> [TxSkelOut]) -> m ()
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Setter) =>
Optic' k is TxSkel a -> (a -> a) -> m ()
overTweak Optic' A_Lens NoIx TxSkel [TxSkelOut]
txSkelOutsL ([TxSkelOut] -> [TxSkelOut] -> [TxSkelOut]
forall a. [a] -> [a] -> [a]
++ [TxSkelOut
txSkelOut])
removeOutputTweak :: (MonadTweak m) => (TxSkelOut -> Bool) -> m [TxSkelOut]
removeOutputTweak :: forall (m :: * -> *).
MonadTweak m =>
(TxSkelOut -> Bool) -> m [TxSkelOut]
removeOutputTweak TxSkelOut -> Bool
removePred = do
[TxSkelOut]
presentOutputs <- Optic' A_Lens NoIx TxSkel [TxSkelOut] -> m [TxSkelOut]
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 [TxSkelOut]
txSkelOutsL
let ([TxSkelOut]
removed, [TxSkelOut]
kept) = (TxSkelOut -> Bool) -> [TxSkelOut] -> ([TxSkelOut], [TxSkelOut])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TxSkelOut -> Bool
removePred [TxSkelOut]
presentOutputs
Optic' A_Lens NoIx TxSkel [TxSkelOut] -> [TxSkelOut] -> 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 [TxSkelOut]
txSkelOutsL [TxSkelOut]
kept
[TxSkelOut] -> m [TxSkelOut]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [TxSkelOut]
removed
data TamperDatumLbl = TamperDatumLbl deriving (Int -> TamperDatumLbl -> ShowS
[TamperDatumLbl] -> ShowS
TamperDatumLbl -> String
(Int -> TamperDatumLbl -> ShowS)
-> (TamperDatumLbl -> String)
-> ([TamperDatumLbl] -> ShowS)
-> Show TamperDatumLbl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TamperDatumLbl -> ShowS
showsPrec :: Int -> TamperDatumLbl -> ShowS
$cshow :: TamperDatumLbl -> String
show :: TamperDatumLbl -> String
$cshowList :: [TamperDatumLbl] -> ShowS
showList :: [TamperDatumLbl] -> ShowS
Show, TamperDatumLbl -> TamperDatumLbl -> Bool
(TamperDatumLbl -> TamperDatumLbl -> Bool)
-> (TamperDatumLbl -> TamperDatumLbl -> Bool) -> Eq TamperDatumLbl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TamperDatumLbl -> TamperDatumLbl -> Bool
== :: TamperDatumLbl -> TamperDatumLbl -> Bool
$c/= :: TamperDatumLbl -> TamperDatumLbl -> Bool
/= :: TamperDatumLbl -> TamperDatumLbl -> Bool
Eq, Eq TamperDatumLbl
Eq TamperDatumLbl =>
(TamperDatumLbl -> TamperDatumLbl -> Ordering)
-> (TamperDatumLbl -> TamperDatumLbl -> Bool)
-> (TamperDatumLbl -> TamperDatumLbl -> Bool)
-> (TamperDatumLbl -> TamperDatumLbl -> Bool)
-> (TamperDatumLbl -> TamperDatumLbl -> Bool)
-> (TamperDatumLbl -> TamperDatumLbl -> TamperDatumLbl)
-> (TamperDatumLbl -> TamperDatumLbl -> TamperDatumLbl)
-> Ord TamperDatumLbl
TamperDatumLbl -> TamperDatumLbl -> Bool
TamperDatumLbl -> TamperDatumLbl -> Ordering
TamperDatumLbl -> TamperDatumLbl -> TamperDatumLbl
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
$ccompare :: TamperDatumLbl -> TamperDatumLbl -> Ordering
compare :: TamperDatumLbl -> TamperDatumLbl -> Ordering
$c< :: TamperDatumLbl -> TamperDatumLbl -> Bool
< :: TamperDatumLbl -> TamperDatumLbl -> Bool
$c<= :: TamperDatumLbl -> TamperDatumLbl -> Bool
<= :: TamperDatumLbl -> TamperDatumLbl -> Bool
$c> :: TamperDatumLbl -> TamperDatumLbl -> Bool
> :: TamperDatumLbl -> TamperDatumLbl -> Bool
$c>= :: TamperDatumLbl -> TamperDatumLbl -> Bool
>= :: TamperDatumLbl -> TamperDatumLbl -> Bool
$cmax :: TamperDatumLbl -> TamperDatumLbl -> TamperDatumLbl
max :: TamperDatumLbl -> TamperDatumLbl -> TamperDatumLbl
$cmin :: TamperDatumLbl -> TamperDatumLbl -> TamperDatumLbl
min :: TamperDatumLbl -> TamperDatumLbl -> TamperDatumLbl
Ord)
instance PrettyCooked TamperDatumLbl where
prettyCooked :: TamperDatumLbl -> DocCooked
prettyCooked TamperDatumLbl
_ = DocCooked
"TamperDatum"
tamperDatumTweak :: forall a m. (MonadTweak m, Api.FromData a, Typeable a) => (a -> Maybe a) -> m [a]
tamperDatumTweak :: forall a (m :: * -> *).
(MonadTweak m, FromData a, Typeable a) =>
(a -> Maybe a) -> m [a]
tamperDatumTweak a -> Maybe a
change = do
[a]
beforeModification <- Optic' A_Traversal NoIx TxSkel a -> (a -> Maybe a) -> m [a]
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Traversal) =>
Optic' k is TxSkel a -> (a -> Maybe a) -> m [a]
overMaybeTweak (Optic' A_Lens NoIx TxSkel [TxSkelOut]
txSkelOutsL Optic' A_Lens NoIx TxSkel [TxSkelOut]
-> Optic
A_Traversal NoIx [TxSkelOut] [TxSkelOut] TxSkelOut TxSkelOut
-> Optic A_Traversal NoIx TxSkel TxSkel TxSkelOut TxSkelOut
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Traversal NoIx [TxSkelOut] [TxSkelOut] TxSkelOut TxSkelOut
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Optic A_Traversal NoIx TxSkel TxSkel TxSkelOut TxSkelOut
-> Optic An_AffineTraversal NoIx TxSkelOut TxSkelOut a a
-> Optic' A_Traversal NoIx TxSkel a
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic An_AffineTraversal NoIx TxSkelOut TxSkelOut a a
forall a. (FromData a, Typeable a) => AffineTraversal' TxSkelOut a
txSkelOutputDatumTypeAT) a -> Maybe a
change
Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> ([a] -> Bool) -> [a] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> m ()) -> [a] -> m ()
forall a b. (a -> b) -> a -> b
$ [a]
beforeModification
TamperDatumLbl -> m ()
forall (m :: * -> *) x. (MonadTweak m, LabelConstrs x) => x -> m ()
addLabelTweak TamperDatumLbl
TamperDatumLbl
[a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
beforeModification
malformDatumTweak :: forall a m. (MonadTweak m, Typeable a) => (a -> [Api.BuiltinData]) -> m ()
malformDatumTweak :: forall a (m :: * -> *).
(MonadTweak m, Typeable a) =>
(a -> [BuiltinData]) -> m ()
malformDatumTweak a -> [BuiltinData]
change = do
[TxSkelOut]
outputs <- Optic A_Traversal NoIx TxSkel TxSkel TxSkelOut TxSkelOut
-> m [TxSkelOut]
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Fold) =>
Optic' k is TxSkel a -> m [a]
viewAllTweak (Optic' A_Lens NoIx TxSkel [TxSkelOut]
txSkelOutsL Optic' A_Lens NoIx TxSkel [TxSkelOut]
-> Optic
A_Traversal NoIx [TxSkelOut] [TxSkelOut] TxSkelOut TxSkelOut
-> Optic A_Traversal NoIx TxSkel TxSkel TxSkelOut TxSkelOut
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Traversal NoIx [TxSkelOut] [TxSkelOut] TxSkelOut TxSkelOut
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed)
let modifiedOutputs :: [[TxSkelOut]]
modifiedOutputs = (TxSkelOut -> [TxSkelOut]) -> [TxSkelOut] -> [[TxSkelOut]]
forall a b. (a -> b) -> [a] -> [b]
map (\TxSkelOut
output -> TxSkelOut
output TxSkelOut -> [TxSkelOut] -> [TxSkelOut]
forall a. a -> [a] -> [a]
: TxSkelOut -> [TxSkelOut]
changeOutput TxSkelOut
output) [TxSkelOut]
outputs
modifiedOutputGroups :: [[TxSkelOut]]
modifiedOutputGroups = [[TxSkelOut]] -> [[TxSkelOut]]
forall a. HasCallStack => [a] -> [a]
tail ([[TxSkelOut]] -> [[TxSkelOut]]) -> [[TxSkelOut]] -> [[TxSkelOut]]
forall a b. (a -> b) -> a -> b
$ [[TxSkelOut]] -> [[TxSkelOut]]
forall a. [[a]] -> [[a]]
allCombinations [[TxSkelOut]]
modifiedOutputs
[m ()] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([m ()] -> m ()) -> [m ()] -> m ()
forall a b. (a -> b) -> a -> b
$ ([TxSkelOut] -> m ()) -> [[TxSkelOut]] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map (Optic' A_Lens NoIx TxSkel [TxSkelOut] -> [TxSkelOut] -> 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 [TxSkelOut]
txSkelOutsL) [[TxSkelOut]]
modifiedOutputGroups
MalformDatumLbl -> m ()
forall (m :: * -> *) x. (MonadTweak m, LabelConstrs x) => x -> m ()
addLabelTweak MalformDatumLbl
MalformDatumLbl
where
changeOutput :: TxSkelOut -> [TxSkelOut]
changeOutput :: TxSkelOut -> [TxSkelOut]
changeOutput (Pays o
out) =
do
let dat :: TxSkelOutDatum
dat = Optic' A_Lens NoIx o TxSkelOutDatum -> o -> TxSkelOutDatum
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' o (DatumType o)
Optic' A_Lens NoIx o TxSkelOutDatum
forall o. IsAbstractOutput o => Lens' o (DatumType o)
outputDatumL o
out
a
typedDat <- Maybe a -> [a]
forall a. Maybe a -> [a]
maybeToList (Maybe a -> [a]) -> Maybe a -> [a]
forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => TxSkelOutDatum -> Maybe a
txSkelOutTypedDatum @a TxSkelOutDatum
dat
BuiltinData
modifiedDat <- a -> [BuiltinData]
change a
typedDat
TxSkelOut -> [TxSkelOut]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (TxSkelOut -> [TxSkelOut]) -> TxSkelOut -> [TxSkelOut]
forall a b. (a -> b) -> a -> b
$ ConcreteOutput
(OwnerType o) TxSkelOutDatum TxSkelOutValue (ReferenceScriptType o)
-> TxSkelOut
forall o.
(Show o, Typeable o, IsTxInfoOutput o,
IsTxSkelOutAllowedOwner (OwnerType o), ToCredential (OwnerType o),
Typeable (OwnerType o), DatumType o ~ TxSkelOutDatum,
ValueType o ~ TxSkelOutValue,
ToVersionedScript (ReferenceScriptType o), Show (OwnerType o),
Show (ReferenceScriptType o), Typeable (ReferenceScriptType o)) =>
o -> TxSkelOut
Pays (ConcreteOutput
(OwnerType o) TxSkelOutDatum TxSkelOutValue (ReferenceScriptType o)
-> TxSkelOut)
-> ConcreteOutput
(OwnerType o) TxSkelOutDatum TxSkelOutValue (ReferenceScriptType o)
-> TxSkelOut
forall a b. (a -> b) -> a -> b
$ o
-> TxSkelOutDatum
-> ConcreteOutput
(OwnerType o) TxSkelOutDatum (ValueType o) (ReferenceScriptType o)
forall out dat.
IsAbstractOutput out =>
out
-> dat
-> ConcreteOutput
(OwnerType out) dat (ValueType out) (ReferenceScriptType out)
setDatum o
out (TxSkelOutDatum
-> ConcreteOutput
(OwnerType o) TxSkelOutDatum (ValueType o) (ReferenceScriptType o))
-> TxSkelOutDatum
-> ConcreteOutput
(OwnerType o) TxSkelOutDatum (ValueType o) (ReferenceScriptType o)
forall a b. (a -> b) -> a -> b
$ case TxSkelOutDatum
dat of
TxSkelOutDatum
TxSkelOutNoDatum -> TxSkelOutDatum
TxSkelOutNoDatum
TxSkelOutDatum a
_ -> BuiltinData -> TxSkelOutDatum
forall a. TxSkelOutDatumConstrs a => a -> TxSkelOutDatum
TxSkelOutDatum BuiltinData
modifiedDat
TxSkelOutDatumHash a
_ -> BuiltinData -> TxSkelOutDatum
forall a. TxSkelOutDatumConstrs a => a -> TxSkelOutDatum
TxSkelOutDatumHash BuiltinData
modifiedDat
TxSkelOutInlineDatum a
_ -> BuiltinData -> TxSkelOutDatum
forall a. TxSkelOutDatumConstrs a => a -> TxSkelOutDatum
TxSkelOutInlineDatum BuiltinData
modifiedDat
data MalformDatumLbl = MalformDatumLbl deriving (Int -> MalformDatumLbl -> ShowS
[MalformDatumLbl] -> ShowS
MalformDatumLbl -> String
(Int -> MalformDatumLbl -> ShowS)
-> (MalformDatumLbl -> String)
-> ([MalformDatumLbl] -> ShowS)
-> Show MalformDatumLbl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MalformDatumLbl -> ShowS
showsPrec :: Int -> MalformDatumLbl -> ShowS
$cshow :: MalformDatumLbl -> String
show :: MalformDatumLbl -> String
$cshowList :: [MalformDatumLbl] -> ShowS
showList :: [MalformDatumLbl] -> ShowS
Show, MalformDatumLbl -> MalformDatumLbl -> Bool
(MalformDatumLbl -> MalformDatumLbl -> Bool)
-> (MalformDatumLbl -> MalformDatumLbl -> Bool)
-> Eq MalformDatumLbl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MalformDatumLbl -> MalformDatumLbl -> Bool
== :: MalformDatumLbl -> MalformDatumLbl -> Bool
$c/= :: MalformDatumLbl -> MalformDatumLbl -> Bool
/= :: MalformDatumLbl -> MalformDatumLbl -> Bool
Eq, Eq MalformDatumLbl
Eq MalformDatumLbl =>
(MalformDatumLbl -> MalformDatumLbl -> Ordering)
-> (MalformDatumLbl -> MalformDatumLbl -> Bool)
-> (MalformDatumLbl -> MalformDatumLbl -> Bool)
-> (MalformDatumLbl -> MalformDatumLbl -> Bool)
-> (MalformDatumLbl -> MalformDatumLbl -> Bool)
-> (MalformDatumLbl -> MalformDatumLbl -> MalformDatumLbl)
-> (MalformDatumLbl -> MalformDatumLbl -> MalformDatumLbl)
-> Ord MalformDatumLbl
MalformDatumLbl -> MalformDatumLbl -> Bool
MalformDatumLbl -> MalformDatumLbl -> Ordering
MalformDatumLbl -> MalformDatumLbl -> MalformDatumLbl
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
$ccompare :: MalformDatumLbl -> MalformDatumLbl -> Ordering
compare :: MalformDatumLbl -> MalformDatumLbl -> Ordering
$c< :: MalformDatumLbl -> MalformDatumLbl -> Bool
< :: MalformDatumLbl -> MalformDatumLbl -> Bool
$c<= :: MalformDatumLbl -> MalformDatumLbl -> Bool
<= :: MalformDatumLbl -> MalformDatumLbl -> Bool
$c> :: MalformDatumLbl -> MalformDatumLbl -> Bool
> :: MalformDatumLbl -> MalformDatumLbl -> Bool
$c>= :: MalformDatumLbl -> MalformDatumLbl -> Bool
>= :: MalformDatumLbl -> MalformDatumLbl -> Bool
$cmax :: MalformDatumLbl -> MalformDatumLbl -> MalformDatumLbl
max :: MalformDatumLbl -> MalformDatumLbl -> MalformDatumLbl
$cmin :: MalformDatumLbl -> MalformDatumLbl -> MalformDatumLbl
min :: MalformDatumLbl -> MalformDatumLbl -> MalformDatumLbl
Ord)
instance PrettyCooked MalformDatumLbl where
prettyCooked :: MalformDatumLbl -> DocCooked
prettyCooked MalformDatumLbl
_ = DocCooked
"MalformDatum"
allCombinations :: [[a]] -> [[a]]
allCombinations :: forall a. [[a]] -> [[a]]
allCombinations [] = [[]]
allCombinations [[]] = []
allCombinations ([a]
first : [[a]]
rest) = [a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs | a
x <- [a]
first, [a]
xs <- [[a]] -> [[a]]
forall a. [[a]] -> [[a]]
allCombinations [[a]]
rest]