-- | This module provides tweaks operating on transaction labels
module Cooked.Tweak.Labels
  ( labelled,
    addLabelTweak,
    removeLabelTweak,
    hasLabelTweak,
    ensureLabelTweak,
    labelled',
  )
where

import Control.Monad
import Cooked.Skeleton
import Cooked.Tweak.Common
import Data.Functor
import Data.Set qualified as Set
import Data.Text (Text)
import Polysemy
import Polysemy.NonDet

-- | Adds a label to a 'TxSkel'.
addLabelTweak ::
  ( LabelConstrs lbl,
    Member Tweak effs
  ) =>
  lbl ->
  Sem effs ()
addLabelTweak :: forall lbl (effs :: EffectRow).
(LabelConstrs lbl, Member Tweak effs) =>
lbl -> Sem effs ()
addLabelTweak = Optic' A_Lens NoIx TxSkel (Set TxSkelLabel)
-> (Set TxSkelLabel -> Set TxSkelLabel) -> Sem effs ()
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Setter) =>
Optic' k is TxSkel a -> (a -> a) -> Sem effs ()
overTweak Optic' A_Lens NoIx TxSkel (Set TxSkelLabel)
txSkelLabelsL ((Set TxSkelLabel -> Set TxSkelLabel) -> Sem effs ())
-> (lbl -> Set TxSkelLabel -> Set TxSkelLabel)
-> lbl
-> Sem effs ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkelLabel -> Set TxSkelLabel -> Set TxSkelLabel
forall a. Ord a => a -> Set a -> Set a
Set.insert (TxSkelLabel -> Set TxSkelLabel -> Set TxSkelLabel)
-> (lbl -> TxSkelLabel)
-> lbl
-> Set TxSkelLabel
-> Set TxSkelLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. lbl -> TxSkelLabel
forall x. LabelConstrs x => x -> TxSkelLabel
TxSkelLabel

-- | Checks if a given label is present in the 'TxSkel'
hasLabelTweak ::
  ( LabelConstrs lbl,
    Member Tweak effs
  ) =>
  lbl ->
  Sem effs Bool
hasLabelTweak :: forall lbl (effs :: EffectRow).
(LabelConstrs lbl, Member Tweak effs) =>
lbl -> Sem effs Bool
hasLabelTweak = (Optic' A_Lens NoIx TxSkel (Set TxSkelLabel)
-> Sem effs (Set TxSkelLabel)
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak Optic' A_Lens NoIx TxSkel (Set TxSkelLabel)
txSkelLabelsL Sem effs (Set TxSkelLabel)
-> (Set TxSkelLabel -> Bool) -> Sem effs Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>) ((Set TxSkelLabel -> Bool) -> Sem effs Bool)
-> (lbl -> Set TxSkelLabel -> Bool) -> lbl -> Sem effs Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkelLabel -> Set TxSkelLabel -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (TxSkelLabel -> Set TxSkelLabel -> Bool)
-> (lbl -> TxSkelLabel) -> lbl -> Set TxSkelLabel -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. lbl -> TxSkelLabel
forall x. LabelConstrs x => x -> TxSkelLabel
TxSkelLabel

-- | Ensures a given label is present in the 'TxSkel'
ensureLabelTweak ::
  ( LabelConstrs lbl,
    Members '[Tweak, NonDet] effs
  ) =>
  lbl ->
  Sem effs ()
ensureLabelTweak :: forall lbl (effs :: EffectRow).
(LabelConstrs lbl, Members '[Tweak, NonDet] effs) =>
lbl -> Sem effs ()
ensureLabelTweak = lbl -> Sem effs Bool
forall lbl (effs :: EffectRow).
(LabelConstrs lbl, Member Tweak effs) =>
lbl -> Sem effs Bool
hasLabelTweak (lbl -> Sem effs Bool)
-> (Bool -> Sem effs ()) -> lbl -> Sem effs ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Bool -> Sem effs ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard

-- | Removes a label from a 'TxSkel' when possible, fails otherwise
removeLabelTweak ::
  ( LabelConstrs lbl,
    Members '[Tweak, NonDet] effs
  ) =>
  lbl ->
  Sem effs ()
removeLabelTweak :: forall lbl (effs :: EffectRow).
(LabelConstrs lbl, Members '[Tweak, NonDet] effs) =>
lbl -> Sem effs ()
removeLabelTweak lbl
lbl = do
  lbl -> Sem effs ()
forall lbl (effs :: EffectRow).
(LabelConstrs lbl, Members '[Tweak, NonDet] effs) =>
lbl -> Sem effs ()
ensureLabelTweak lbl
lbl
  Optic' A_Lens NoIx TxSkel (Set TxSkelLabel)
-> (Set TxSkelLabel -> Set TxSkelLabel) -> Sem effs ()
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Setter) =>
Optic' k is TxSkel a -> (a -> a) -> Sem effs ()
overTweak Optic' A_Lens NoIx TxSkel (Set TxSkelLabel)
txSkelLabelsL ((Set TxSkelLabel -> Set TxSkelLabel) -> Sem effs ())
-> (TxSkelLabel -> Set TxSkelLabel -> Set TxSkelLabel)
-> TxSkelLabel
-> Sem effs ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkelLabel -> Set TxSkelLabel -> Set TxSkelLabel
forall a. Ord a => a -> Set a -> Set a
Set.delete (TxSkelLabel -> Sem effs ()) -> TxSkelLabel -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ lbl -> TxSkelLabel
forall x. LabelConstrs x => x -> TxSkelLabel
TxSkelLabel lbl
lbl

-- | Apply a tweak to a given transaction if it has a specific label. Fails if
-- it does not.
--
-- >
-- > someEndpoint = do
-- >   ...
-- >   validateTxSkel' txSkelTemplate
-- >      { txSkelLabels =
-- >         [ "InitialMinting"
-- >         , "AuctionWorkflow"
-- >         , label SomeLabelType]
-- >      }
-- >
-- > someTest = someEndpoint & eveywhere (labelled SomeLabelType someTweak)
-- > anotherTest = someEndpoint & somewhere (labelled SomeLabelType someTweak)
labelled ::
  ( LabelConstrs lbl,
    Members '[Tweak, NonDet] effs
  ) =>
  lbl ->
  Sem effs a ->
  Sem effs a
labelled :: forall lbl (effs :: EffectRow) a.
(LabelConstrs lbl, Members '[Tweak, NonDet] effs) =>
lbl -> Sem effs a -> Sem effs a
labelled lbl
lbl = (lbl -> Sem effs ()
forall lbl (effs :: EffectRow).
(LabelConstrs lbl, Members '[Tweak, NonDet] effs) =>
lbl -> Sem effs ()
ensureLabelTweak lbl
lbl Sem effs () -> Sem effs a -> Sem effs a
forall a b. Sem effs a -> Sem effs b -> Sem effs b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>)

-- | `labelled` specialised to Text labels
--
-- >
-- > someEndpoint = do
-- >   ...
-- >   validateTxSkel' txSkelTemplate
-- >      { txSkelLabels =
-- >         [ "InitialMinting"
-- >         , "AuctionWorkflow"
-- >         , "Spending"
-- >         , label SomeLabelType]
-- >      }
-- >
-- > someTest = someEndpoint & somewhere (labelled' "Spending" doubleSatAttack)
labelled' ::
  (Members '[Tweak, NonDet] effs) =>
  Text ->
  Sem effs a ->
  Sem effs a
labelled' :: forall (effs :: EffectRow) a.
Members '[Tweak, NonDet] effs =>
Text -> Sem effs a -> Sem effs a
labelled' = Text -> Sem effs a -> Sem effs a
forall lbl (effs :: EffectRow) a.
(LabelConstrs lbl, Members '[Tweak, NonDet] effs) =>
lbl -> Sem effs a -> Sem effs a
labelled