-- | This module exposes tweaks revolving around parts of a 'TxSkel' satisfying
-- given conditions. The only parameter these tweaks take is an optic, and the
-- guards ensure that at least one focus is targeted by it. This might look
-- insufficient, but thanks to @filtered@ which turns a predicate into an
-- optic, this is actually sufficiently expressive. For example, if you have an
-- optic @o@ targeting an element of type @a@, and a predicate @p@ and would
-- like to ensure the targeted elements satisfy @p@, use @o % filtered p@.
module Cooked.Tweak.Guard
  ( -- * Standard guarding tweaks
    assertTweak,
    guardTweak,
    condTweak,

    -- * Custom guarding tweaks
    labelled,
    labelled',
  )
where

import Control.Monad
import Cooked.Skeleton
import Cooked.Tweak.Common
import Cooked.Tweak.Query
import Data.Text (Text)
import Optics.Core
import Polysemy
import Polysemy.NonDet

-- | Asserts whether a given optic targets at least one focus
assertTweak ::
  ( Member Tweak effs,
    Is k A_Fold
  ) =>
  Optic' k is TxSkel a ->
  Sem effs Bool
assertTweak :: forall (effs :: EffectRow) (k :: OpticKind) (is :: IxList)
       (a :: OpticKind).
(Member Tweak effs, Is k A_Fold) =>
Optic' k is TxSkel a -> Sem effs Bool
assertTweak = ([a] -> Bool) -> Sem effs [a] -> Sem effs Bool
forall (a :: OpticKind) (b :: OpticKind).
(a -> b) -> Sem effs a -> Sem effs b
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
fmap (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (a :: OpticKind). [a] -> Bool
forall (t :: OpticKind -> OpticKind) (a :: OpticKind).
Foldable t =>
t a -> Bool
null) (Sem effs [a] -> Sem effs Bool)
-> (Optic' k is TxSkel a -> Sem effs [a])
-> Optic' k is TxSkel a
-> Sem effs Bool
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. Optic' k is TxSkel a -> Sem effs [a]
forall (effs :: EffectRow) (k :: OpticKind) (is :: IxList)
       (a :: OpticKind).
(Member Tweak effs, Is k A_Fold) =>
Optic' k is TxSkel a -> Sem effs [a]
toListOfTweak

-- | Ensures a given optic targets at least one focus, failing otherwise
guardTweak ::
  ( Members '[Tweak, NonDet] effs,
    Is k A_Fold
  ) =>
  Optic' k is TxSkel a ->
  Sem effs ()
guardTweak :: forall (effs :: EffectRow) (k :: OpticKind) (is :: IxList)
       (a :: OpticKind).
(Members '[Tweak, NonDet] effs, Is k A_Fold) =>
Optic' k is TxSkel a -> Sem effs ()
guardTweak Optic' k is TxSkel a
optic = Optic' k is TxSkel a -> Sem effs Bool
forall (effs :: EffectRow) (k :: OpticKind) (is :: IxList)
       (a :: OpticKind).
(Member Tweak effs, Is k A_Fold) =>
Optic' k is TxSkel a -> Sem effs Bool
assertTweak Optic' k is TxSkel a
optic Sem effs Bool -> (Bool -> Sem effs ()) -> Sem effs ()
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
>>= Bool -> Sem effs ()
forall (f :: OpticKind -> OpticKind). Alternative f => Bool -> f ()
guard

-- | Only executes the given computation provided the given optic targets at
-- least one focus, failing otherwise.
condTweak ::
  ( Members '[Tweak, NonDet] effs,
    Is k A_Fold
  ) =>
  Optic' k is TxSkel a ->
  Sem effs b ->
  Sem effs b
condTweak :: forall (effs :: EffectRow) (k :: OpticKind) (is :: IxList)
       (a :: OpticKind) (b :: OpticKind).
(Members '[Tweak, NonDet] effs, Is k A_Fold) =>
Optic' k is TxSkel a -> Sem effs b -> Sem effs b
condTweak Optic' k is TxSkel a
optic = (Optic' k is TxSkel a -> Sem effs ()
forall (effs :: EffectRow) (k :: OpticKind) (is :: IxList)
       (a :: OpticKind).
(Members '[Tweak, NonDet] effs, Is k A_Fold) =>
Optic' k is TxSkel a -> Sem effs ()
guardTweak Optic' k is TxSkel a
optic Sem effs () -> Sem effs b -> Sem effs b
forall (a :: OpticKind) (b :: OpticKind).
Sem effs a -> Sem effs b -> Sem effs b
forall (m :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Monad m =>
m a -> m b -> m b
>>)

-- | Apply a tweak to a given transaction if it has a specific label. Fails if
-- it does not.
--
-- >
-- > someEndpoint = do
-- >   ...
-- >   validateTxSkel' txSkelTemplate
-- >      { txSkelLabels =
-- >         [ TxSkelLabel "InitialMinting"
-- >         , TxSkelLabel "AuctionWorkflow"
-- >         , TxSkelLabel SomeLabelType]
-- >      }
-- >
-- > someTest = someEndpoint & everywhere (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 :: OpticKind) (effs :: EffectRow) (a :: OpticKind).
(LabelConstrs lbl, Members '[Tweak, NonDet] effs) =>
lbl -> Sem effs a -> Sem effs a
labelled lbl
lbl = Optic' An_AffineTraversal '[] TxSkel () -> Sem effs a -> Sem effs a
forall (effs :: EffectRow) (k :: OpticKind) (is :: IxList)
       (a :: OpticKind) (b :: OpticKind).
(Members '[Tweak, NonDet] effs, Is k A_Fold) =>
Optic' k is TxSkel a -> Sem effs b -> Sem effs b
condTweak (Optic' An_AffineTraversal '[] TxSkel ()
 -> Sem effs a -> Sem effs a)
-> Optic' An_AffineTraversal '[] TxSkel ()
-> Sem effs a
-> Sem effs a
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Lens' TxSkel (Set TxSkelLabel)
txSkelLabelsL Lens' TxSkel (Set TxSkelLabel)
-> Optic
     A_Lens
     '[]
     (Set TxSkelLabel)
     (Set TxSkelLabel)
     (Maybe ())
     (Maybe ())
-> Optic A_Lens '[] TxSkel TxSkel (Maybe ()) (Maybe ())
forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(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
% Index (Set TxSkelLabel)
-> Lens' (Set TxSkelLabel) (Maybe (IxValue (Set TxSkelLabel)))
forall (m :: OpticKind).
At m =>
Index m -> Lens' m (Maybe (IxValue m))
at (lbl -> TxSkelLabel
forall (x :: OpticKind). LabelConstrs x => x -> TxSkelLabel
TxSkelLabel lbl
lbl) Optic A_Lens '[] TxSkel TxSkel (Maybe ()) (Maybe ())
-> Optic A_Prism '[] (Maybe ()) (Maybe ()) () ()
-> Optic' An_AffineTraversal '[] TxSkel ()
forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(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_Prism '[] (Maybe ()) (Maybe ()) () ()
forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just

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