-- | This module defines 'Tweak's which are the fundamental building blocks of
-- our "domain specific language" for attacks. They are essentially skeleton
-- modifications aware of the mockchain state.
module Cooked.Tweak.Common
  ( runTweak,
    runTweakFrom,
    runTweakInChain,
    runTweakInChain',
    Tweak,
    UntypedTweak (..),

    -- * User API
    MonadTweak (..),
    failingTweak,
    doNothingTweak,
    viewTweak,
    viewAllTweak,
    setTweak,
    overTweak,
    overMaybeTweak,
    overMaybeSelectingTweak,
    selectP,
    combineModsTweak,
    iviewTweak,
    ensureFailingTweak,
  )
where

import Control.Arrow (second)
import Control.Monad
import Control.Monad.State
import Cooked.InitialDistribution
import Cooked.MockChain.BlockChain
import Cooked.MockChain.Direct
import Cooked.Skeleton
import Data.Default
import Data.Either.Combinators (rightToMaybe)
import Data.List (mapAccumL)
import Data.Maybe
import ListT (ListT)
import ListT qualified
import Optics.Core

-- * The type of tweaks

-- | A 'MonadTweak' is a 'MonadBlockChainWithoutValidation' where you can also
-- retrieve and store a 'TxSkel'
class (MonadPlus m, MonadBlockChainWithoutValidation m) => MonadTweak m where
  -- | Retrieves the stored 'TxSkel'
  getTxSkel :: m TxSkel

  -- | Stores a 'TxSkel'
  putTxSkel :: TxSkel -> m ()

-- | A 'Tweak' is the most natural instance of 'MonadTweak' where the storing
-- and retrieving of the 'TxSkel' is performed through a state monad
type Tweak m = StateT TxSkel (ListT m)

instance (MonadBlockChainWithoutValidation m) => MonadTweak (Tweak m) where
  getTxSkel :: Tweak m TxSkel
getTxSkel = Tweak m TxSkel
forall s (m :: * -> *). MonadState s m => m s
get
  putTxSkel :: TxSkel -> Tweak m ()
putTxSkel = TxSkel -> Tweak m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put

-- * Running tweaks

-- | This is the function that gives a meaning to 'Tweak's: A 'Tweak' is a
-- computation that, depending on the state of the chain, looks at a transaction
-- and returns zero or more modified transactions, together with some additional
-- values.
--
-- Our intuition (and also the language of the comments pertaining to 'Tweak's)
-- is that a 'Tweak' @t@
--
-- - /fails/ if @runTweakInChain t skel@ is @mzero@.
--
-- - /returns/ the value in the first component of the pair returned by this
--   function (which is also the value it returns in the monad @Tweak m@).
--
-- - /modifies/ a 'TxSkel'. Since it can use every method of
--   'MonadBlockChainWithoutValidation' to do so, this also includes stateful
--   lookups or even things like waiting for a certain amount of time before
--   submitting the transaction.
--
-- If you're using tweaks in a 'Cooked.MockChain.Staged.MonadModalBlockChain'
-- together with mechanisms like 'Cooked.MockChain.Staged.withTweak',
-- 'Cooked.MockChain.Staged.somewhere', or 'Cooked.MockChain.Staged.everywhere',
-- you should never have a reason to use this function.
runTweakInChain :: (MonadPlus m) => Tweak m a -> TxSkel -> m (a, TxSkel)
runTweakInChain :: forall (m :: * -> *) a.
MonadPlus m =>
Tweak m a -> TxSkel -> m (a, TxSkel)
runTweakInChain Tweak m a
tweak = ListT m (a, TxSkel) -> m (a, TxSkel)
forall (m :: * -> *) a.
(Alternative m, Monad m) =>
ListT m a -> m a
ListT.alternate (ListT m (a, TxSkel) -> m (a, TxSkel))
-> (TxSkel -> ListT m (a, TxSkel)) -> TxSkel -> m (a, TxSkel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tweak m a -> TxSkel -> ListT m (a, TxSkel)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Tweak m a
tweak

-- | Like 'runTweakInChain', but for when you want to explicitly apply a tweak
-- to a transaction skeleton and get all results as a list.
--
-- If you're trying to apply a tweak to a transaction directly before it's
-- modified, consider using 'Cooked.MockChain.Staged.MonadModalBlockChain' and
-- idioms like 'Cooked.MockChain.Staged.withTweak',
-- 'Cooked.MockChain.Staged.somewhere', or 'Cooked.MockChain.Staged.everywhere'.
runTweakInChain' :: (MonadPlus m) => Tweak m a -> TxSkel -> m [(a, TxSkel)]
runTweakInChain' :: forall (m :: * -> *) a.
MonadPlus m =>
Tweak m a -> TxSkel -> m [(a, TxSkel)]
runTweakInChain' Tweak m a
tweak = ListT m (a, TxSkel) -> m [(a, TxSkel)]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList (ListT m (a, TxSkel) -> m [(a, TxSkel)])
-> (TxSkel -> ListT m (a, TxSkel)) -> TxSkel -> m [(a, TxSkel)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tweak m a -> TxSkel -> ListT m (a, TxSkel)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Tweak m a
tweak

-- | Runs a 'Tweak' from a given 'TxSkel' within a mockchain
runTweak :: (MonadPlus m) => Tweak (MockChainT m) a -> TxSkel -> m (MockChainReturn (a, TxSkel))
runTweak :: forall (m :: * -> *) a.
MonadPlus m =>
Tweak (MockChainT m) a -> TxSkel -> m (MockChainReturn (a, TxSkel))
runTweak = InitialDistribution
-> Tweak (MockChainT m) a
-> TxSkel
-> m (MockChainReturn (a, TxSkel))
forall (m :: * -> *) a.
MonadPlus m =>
InitialDistribution
-> Tweak (MockChainT m) a
-> TxSkel
-> m (MockChainReturn (a, TxSkel))
runTweakFrom InitialDistribution
forall a. Default a => a
def

-- | Runs a 'Tweak' from a given 'TxSkel' and 'InitialDistribution' within a
-- mockchain
runTweakFrom :: (MonadPlus m) => InitialDistribution -> Tweak (MockChainT m) a -> TxSkel -> m (MockChainReturn (a, TxSkel))
runTweakFrom :: forall (m :: * -> *) a.
MonadPlus m =>
InitialDistribution
-> Tweak (MockChainT m) a
-> TxSkel
-> m (MockChainReturn (a, TxSkel))
runTweakFrom InitialDistribution
initDist Tweak (MockChainT m) a
tweak = InitialDistribution
-> MockChainT m (a, TxSkel) -> m (MockChainReturn (a, TxSkel))
forall (m :: * -> *) a.
Monad m =>
InitialDistribution -> MockChainT m a -> m (MockChainReturn a)
runMockChainTFromInitDist InitialDistribution
initDist (MockChainT m (a, TxSkel) -> m (MockChainReturn (a, TxSkel)))
-> (TxSkel -> MockChainT m (a, TxSkel))
-> TxSkel
-> m (MockChainReturn (a, TxSkel))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tweak (MockChainT m) a -> TxSkel -> MockChainT m (a, TxSkel)
forall (m :: * -> *) a.
MonadPlus m =>
Tweak m a -> TxSkel -> m (a, TxSkel)
runTweakInChain Tweak (MockChainT m) a
tweak

-- | This is a wrapper type used in the implementation of the Staged monad. You
-- will probably never use it while you're building 'Tweak's.
data UntypedTweak m where
  UntypedTweak :: Tweak m a -> UntypedTweak m

-- * A few fundamental tweaks

-- | The never-applicable 'Tweak'.
failingTweak :: (MonadTweak m) => m a
failingTweak :: forall (m :: * -> *) a. MonadTweak m => m a
failingTweak = m a
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | The 'Tweak' that always applies and leaves the transaction unchanged.
doNothingTweak :: (MonadTweak m) => m ()
doNothingTweak :: forall (m :: * -> *). MonadTweak m => m ()
doNothingTweak = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | The 'Tweak' that ensures a given tweak fails
ensureFailingTweak :: (MonadPlus m) => Tweak m a -> Tweak m ()
ensureFailingTweak :: forall (m :: * -> *) a. MonadPlus m => Tweak m a -> Tweak m ()
ensureFailingTweak Tweak m a
comp = do
  TxSkel
skel <- StateT TxSkel (ListT m) TxSkel
forall s (m :: * -> *). MonadState s m => m s
get
  [(a, TxSkel)]
res <- ListT m [(a, TxSkel)] -> StateT TxSkel (ListT m) [(a, TxSkel)]
forall (m :: * -> *) a. Monad m => m a -> StateT TxSkel m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ListT m [(a, TxSkel)] -> StateT TxSkel (ListT m) [(a, TxSkel)])
-> ListT m [(a, TxSkel)] -> StateT TxSkel (ListT m) [(a, TxSkel)]
forall a b. (a -> b) -> a -> b
$ m [(a, TxSkel)] -> ListT m [(a, TxSkel)]
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [(a, TxSkel)] -> ListT m [(a, TxSkel)])
-> m [(a, TxSkel)] -> ListT m [(a, TxSkel)]
forall a b. (a -> b) -> a -> b
$ Tweak m a -> TxSkel -> m [(a, TxSkel)]
forall (m :: * -> *) a.
MonadPlus m =>
Tweak m a -> TxSkel -> m [(a, TxSkel)]
runTweakInChain' Tweak m a
comp TxSkel
skel
  Bool -> Tweak m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Tweak m ()) -> Bool -> Tweak m ()
forall a b. (a -> b) -> a -> b
$ [(a, TxSkel)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, TxSkel)]
res

-- * Constructing Tweaks from Optics

-- | Retrieves some value from the 'TxSkel'
viewTweak :: (MonadTweak m, Is k A_Getter) => Optic' k is TxSkel a -> m a
viewTweak :: forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Getter) =>
Optic' k is TxSkel a -> m a
viewTweak Optic' k is TxSkel a
optic = m TxSkel
forall (m :: * -> *). MonadTweak m => m TxSkel
getTxSkel m TxSkel -> (TxSkel -> a) -> m a
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Optic' k is TxSkel a -> TxSkel -> a
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' k is TxSkel a
optic

-- | Like 'viewTweak', only for indexed optics.
iviewTweak :: (MonadTweak m, Is k A_Getter) => Optic' k (WithIx is) TxSkel a -> m (is, a)
iviewTweak :: forall (m :: * -> *) k is a.
(MonadTweak m, Is k A_Getter) =>
Optic' k (WithIx is) TxSkel a -> m (is, a)
iviewTweak Optic' k (WithIx is) TxSkel a
optic = m TxSkel
forall (m :: * -> *). MonadTweak m => m TxSkel
getTxSkel m TxSkel -> (TxSkel -> (is, a)) -> m (is, a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Optic' k (WithIx is) TxSkel a -> TxSkel -> (is, a)
forall k (is :: IxList) i s a.
(Is k A_Getter, HasSingleIndex is i) =>
Optic' k is s a -> s -> (i, a)
iview Optic' k (WithIx is) TxSkel a
optic

-- | Like the 'viewTweak', but returns a list of all foci
viewAllTweak :: (MonadTweak m, Is k A_Fold) => Optic' k is TxSkel a -> m [a]
viewAllTweak :: forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Fold) =>
Optic' k is TxSkel a -> m [a]
viewAllTweak Optic' k is TxSkel a
optic = m TxSkel
forall (m :: * -> *). MonadTweak m => m TxSkel
getTxSkel m TxSkel -> (TxSkel -> [a]) -> m [a]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Optic' k is TxSkel a -> TxSkel -> [a]
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> [a]
toListOf Optic' k is TxSkel a
optic

-- | The tweak that sets a certain value in the 'TxSkel'.
setTweak :: (MonadTweak m, Is k A_Setter) => Optic' k is TxSkel a -> a -> m ()
setTweak :: forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> m ()
setTweak Optic' k is TxSkel a
optic = Optic' k is TxSkel a -> (a -> a) -> m ()
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Setter) =>
Optic' k is TxSkel a -> (a -> a) -> m ()
overTweak Optic' k is TxSkel a
optic ((a -> a) -> m ()) -> (a -> a -> a) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> a
forall a b. a -> b -> a
const

-- | The tweak that modifies a certain value in the 'TxSkel'.
overTweak :: (MonadTweak m, Is k A_Setter) => Optic' k is TxSkel a -> (a -> a) -> m ()
overTweak :: forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Setter) =>
Optic' k is TxSkel a -> (a -> a) -> m ()
overTweak Optic' k is TxSkel a
optic a -> a
change = m TxSkel
forall (m :: * -> *). MonadTweak m => m TxSkel
getTxSkel m TxSkel -> (TxSkel -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TxSkel -> m ()
forall (m :: * -> *). MonadTweak m => TxSkel -> m ()
putTxSkel (TxSkel -> m ()) -> (TxSkel -> TxSkel) -> TxSkel -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' k is TxSkel a -> (a -> a) -> TxSkel -> TxSkel
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic' k is TxSkel a
optic a -> a
change

-- | Like 'overTweak', but only modifies foci on which the argument function
-- returns @Just@ the new focus. Returns a list of the foci that were modified,
-- as they were /before/ the tweak, and in the order in which they occurred on
-- the original transaction.
overMaybeTweak :: (MonadTweak m, Is k A_Traversal) => Optic' k is TxSkel a -> (a -> Maybe a) -> m [a]
overMaybeTweak :: forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Traversal) =>
Optic' k is TxSkel a -> (a -> Maybe a) -> m [a]
overMaybeTweak Optic' k is TxSkel a
optic a -> Maybe a
mChange = Optic' k is TxSkel a
-> (a -> Maybe a) -> (Integer -> Bool) -> m [a]
forall a (m :: * -> *) k (is :: IxList).
(MonadTweak m, Is k A_Traversal) =>
Optic' k is TxSkel a
-> (a -> Maybe a) -> (Integer -> Bool) -> m [a]
overMaybeSelectingTweak Optic' k is TxSkel a
optic a -> Maybe a
mChange (Bool -> Integer -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Sometimes 'overMaybeTweak' modifies too many foci. This might be the case
-- if there are several identical foci, but you only want to modify some of
-- them. This is where this 'Tweak' becomes useful: The @(Integer -> Bool)@
-- argument can be used to select which of the modifiable foci should be
-- actually modified.
overMaybeSelectingTweak ::
  forall a m k is.
  (MonadTweak m, Is k A_Traversal) =>
  Optic' k is TxSkel a ->
  (a -> Maybe a) ->
  (Integer -> Bool) ->
  m [a]
overMaybeSelectingTweak :: forall a (m :: * -> *) k (is :: IxList).
(MonadTweak m, Is k A_Traversal) =>
Optic' k is TxSkel a
-> (a -> Maybe a) -> (Integer -> Bool) -> m [a]
overMaybeSelectingTweak Optic' k is TxSkel a
optic a -> Maybe a
mChange Integer -> Bool
select = do
  [a]
allFoci <- Optic' A_Lens '[] TxSkel [a] -> m [a]
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Getter) =>
Optic' k is TxSkel a -> m a
viewTweak (Optic' A_Lens '[] TxSkel [a] -> m [a])
-> Optic' A_Lens '[] TxSkel [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ Optic' k is TxSkel a -> Optic' A_Lens '[] TxSkel [a]
forall k (is :: IxList) s t a.
Is k A_Traversal =>
Optic k is s t a a -> Lens s t [a] [a]
partsOf Optic' k is TxSkel a
optic
  let evaluatedFoci :: [(a, Maybe a)]
      evaluatedFoci :: [(a, Maybe a)]
evaluatedFoci =
        (Integer, [(a, Maybe a)]) -> [(a, Maybe a)]
forall a b. (a, b) -> b
snd ((Integer, [(a, Maybe a)]) -> [(a, Maybe a)])
-> (Integer, [(a, Maybe a)]) -> [(a, Maybe a)]
forall a b. (a -> b) -> a -> b
$
          (Integer -> a -> (Integer, (a, Maybe a)))
-> Integer -> [a] -> (Integer, [(a, Maybe a)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL
            ( \Integer
i a
unmodifiedFocus ->
                case a -> Maybe a
mChange a
unmodifiedFocus of
                  Just a
modifiedFocus ->
                    if Integer -> Bool
select Integer
i
                      then (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1, (a
unmodifiedFocus, a -> Maybe a
forall a. a -> Maybe a
Just a
modifiedFocus))
                      else (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1, (a
unmodifiedFocus, Maybe a
forall a. Maybe a
Nothing))
                  Maybe a
Nothing -> (Integer
i, (a
unmodifiedFocus, Maybe a
forall a. Maybe a
Nothing))
            )
            Integer
0
            [a]
allFoci
  -- If the second component of the pair is @Just@, use it.
  Optic' A_Lens '[] TxSkel [a] -> [a] -> m ()
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> m ()
setTweak (Optic' k is TxSkel a -> Optic' A_Lens '[] TxSkel [a]
forall k (is :: IxList) s t a.
Is k A_Traversal =>
Optic k is s t a a -> Lens s t [a] [a]
partsOf Optic' k is TxSkel a
optic) ([a] -> m ()) -> [a] -> m ()
forall a b. (a -> b) -> a -> b
$ ((a, Maybe a) -> a) -> [(a, Maybe a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Maybe a -> a) -> (a, Maybe a) -> a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe) [(a, Maybe a)]
evaluatedFoci
  [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$
    ((a, Maybe a) -> Maybe a) -> [(a, Maybe a)] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
      (\(a
original, Maybe a
mNew) -> if Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
mNew then a -> Maybe a
forall a. a -> Maybe a
Just a
original else Maybe a
forall a. Maybe a
Nothing)
      [(a, Maybe a)]
evaluatedFoci

-- | When constructing a tweak from an optic and a modification of foci, there
-- are in principle two options for optics with many foci: (a) apply the
-- modification to all foci and return /one/ modified transaction (b) generate a
-- number of transactions that contain different combinations of modified and
-- un-modified foci.
--
-- While most of the other "optic -> tweak" functions in this module take take
-- the route (a), this function enables strategy (b).
--
--
-- __Explanation of the arguments and return value__
--
-- - Each of the foci of the @Optic k (WithIx is) TxSkel x@ argument is
--   something in the transaction that we might want to modify.
--
-- - The @is -> x -> m [(x, l)]@ argument computes a list of possible
--   modifications for each focus, depending on its index. For each modified
--   focus, it also returns a "label" of type @l@, which somehow describes the
--   modification that was made.
--
-- - The @[is] -> [[is]]@ argument determines which combinations of (un-)
--   modified foci will be present on the modified transactions: The input is a
--   list of all of the indices of foci, and for each element @[i_1,...,i_n]@ of
--   the output list, all possible modified transactions that have a
--   modification applied to the foci with indices @i_1,...,i_n@ are generated.
--
-- - The return value of type @[l]@ is the list of labels of all modified foci,
--   in the order in which their indices occurred. Later tweaks may use this
--   list to decide what to do.
--
--
-- __Example 1__
--
-- Assume the optic has three foci, let's denote them by @a, b, c :: x@, with
-- indices @1, 2, 3 :: Integer@ respectively. Also assume that the @is -> x -> m
-- [(x, l)]@ argument returns lists of 2, 3, and 5 elements on @a@, @b@, and
-- @c@, respectively. Let's call those elements @a1, a2@ and @b1, b2, b3@ and
-- @c1, c2, c3, c4, c5@.
--
-- If the @[ix] -> [[ix]]@ argument is @map (:[])@, you will try every
-- modification on a separate transaction, since
--
-- > map (:[]) [1, 2, 3] = [[1], [2], [3]]  .
--
-- Thus, there'll be 2+3+5=10 modified transactions in our examples. Namely, for
-- each element of the list
--
-- > [a1, a2, b1, b2, b3, c1, c2, c3, c4, c5]
--
-- you'll get one modified transaction that includes that value in place of the
-- original focus.
--
-- __Example 2__
--
-- In the setting of the first example, if you want to try combining all
-- possible modifications of one focus with all possible modifications of all
-- other foci, choose @tail . subsequences@ for the @[ix] -> [[ix]] argument. We
-- have
--
-- > tail (subsequences [1, 2, 3])
-- >   == [ [1], [2], [3],
-- >        [1, 2], [1, 3], [2, 3],
-- >        [1, 2, 3]
-- >      ]
--
-- This will correspond to the following 71 modified transactions, represented
-- by the list of modified foci they contain:
--
-- > [ -- one modified focus (the 10 cases from Example 1)
-- >   [a1],
-- >   [a2],
-- >   ...
-- >   [c4],
-- >   [c5],
-- >
-- >   -- two modifications of different foci (2*3 + 2*5 + 3*5 = 31 cases)
-- >   [a1, b1],
-- >   [a1, b2],
-- >   ...
-- >   [b3, c4],
-- >   [b3, c5],
-- >
-- >   -- three modified foci, one from each focus (2*3*5 = 30 cases)
-- >   [a1, b1, c1],
-- >   [a1, b1, c2],
-- >   ...
-- >   [a1, b3, c4],
-- >   [a1, b3, c5]
-- > ]
--
-- So you see that tweaks constructed like this can branch quite wildly. Use
-- with caution!
combineModsTweak ::
  (Eq is, Is k A_Traversal, MonadTweak m) =>
  ([is] -> [[is]]) ->
  Optic' k (WithIx is) TxSkel x ->
  (is -> x -> m [(x, l)]) ->
  m [l]
combineModsTweak :: forall is k (m :: * -> *) x l.
(Eq is, Is k A_Traversal, MonadTweak m) =>
([is] -> [[is]])
-> Optic' k (WithIx is) TxSkel x
-> (is -> x -> m [(x, l)])
-> m [l]
combineModsTweak [is] -> [[is]]
groupings Optic' k (WithIx is) TxSkel x
optic is -> x -> m [(x, l)]
changes = do
  ([is]
indexes, [x]
foci) <- Optic' A_Lens (WithIx [is]) TxSkel [x] -> m ([is], [x])
forall (m :: * -> *) k is a.
(MonadTweak m, Is k A_Getter) =>
Optic' k (WithIx is) TxSkel a -> m (is, a)
iviewTweak (Optic' k (WithIx is) TxSkel x
-> Optic' A_Lens (WithIx [is]) TxSkel [x]
forall k (is :: IxList) i s t a.
(Is k A_Traversal, HasSingleIndex is i) =>
Optic k is s t a a -> IxLens [i] s t [a] [a]
ipartsOf Optic' k (WithIx is) TxSkel x
optic)
  [m [l]] -> m [l]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([m [l]] -> m [l]) -> [m [l]] -> m [l]
forall a b. (a -> b) -> a -> b
$
    ([is] -> m [l]) -> [[is]] -> [m [l]]
forall a b. (a -> b) -> [a] -> [b]
map
      ( \[is]
grouping -> do
          let mChangedFoci :: [m [(x, Either () l)]]
mChangedFoci =
                (is -> x -> m [(x, Either () l)])
-> [is] -> [x] -> [m [(x, Either () l)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                  ( \is
i x
a ->
                      if is
i is -> [is] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [is]
grouping
                        then ((x, l) -> (x, Either () l)) -> [(x, l)] -> [(x, Either () l)]
forall a b. (a -> b) -> [a] -> [b]
map ((l -> Either () l) -> (x, l) -> (x, Either () l)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second l -> Either () l
forall a b. b -> Either a b
Right) ([(x, l)] -> [(x, Either () l)])
-> m [(x, l)] -> m [(x, Either () l)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> is -> x -> m [(x, l)]
changes is
i x
a
                        else [(x, Either () l)] -> m [(x, Either () l)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(x
a, () -> Either () l
forall a b. a -> Either a b
Left ())]
                  )
                  [is]
indexes
                  [x]
foci
          [[(x, Either () l)]]
changedFoci <- [m [(x, Either () l)]] -> m [[(x, Either () l)]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [m [(x, Either () l)]]
mChangedFoci
          [m [l]] -> m [l]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([m [l]] -> m [l]) -> [m [l]] -> m [l]
forall a b. (a -> b) -> a -> b
$
            ([(x, Either () l)] -> m [l]) -> [[(x, Either () l)]] -> [m [l]]
forall a b. (a -> b) -> [a] -> [b]
map
              ( \[(x, Either () l)]
combination -> do
                  Optic' A_Lens '[] TxSkel [x] -> [x] -> m ()
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> m ()
setTweak (Optic' k (WithIx is) TxSkel x -> Optic' A_Lens '[] TxSkel [x]
forall k (is :: IxList) s t a.
Is k A_Traversal =>
Optic k is s t a a -> Lens s t [a] [a]
partsOf Optic' k (WithIx is) TxSkel x
optic) ([x] -> m ()) -> [x] -> m ()
forall a b. (a -> b) -> a -> b
$ ((x, Either () l) -> x) -> [(x, Either () l)] -> [x]
forall a b. (a -> b) -> [a] -> [b]
map (x, Either () l) -> x
forall a b. (a, b) -> a
fst [(x, Either () l)]
combination
                  [l] -> m [l]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([l] -> m [l]) -> [l] -> m [l]
forall a b. (a -> b) -> a -> b
$ ((x, Either () l) -> Maybe l) -> [(x, Either () l)] -> [l]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Either () l -> Maybe l
forall a b. Either a b -> Maybe b
rightToMaybe (Either () l -> Maybe l)
-> ((x, Either () l) -> Either () l) -> (x, Either () l) -> Maybe l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x, Either () l) -> Either () l
forall a b. (a, b) -> b
snd) [(x, Either () l)]
combination
              )
              ([[(x, Either () l)]] -> [[(x, Either () l)]]
forall a. [[a]] -> [[a]]
allCombinations [[(x, Either () l)]]
changedFoci)
      )
      ([is] -> [[is]]
groupings [is]
indexes)
  where
    allCombinations :: [[a]] -> [[a]]
    allCombinations :: forall a. [[a]] -> [[a]]
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]

-- | 'overMaybeTweak' requires a modification that can fail (targeting 'Maybe').
-- Sometimes, it can prove more convenient to explicitly state which property
-- the foci shoud satisfy to be eligible for a modification that cannot fail
-- instead. 'selectP' provides a prism to make such a selection.  The intended
-- use case is @overTweak (optic % selectP prop) mod@ where @optic@ gives the
-- candidate foci, @prop@ is the predicate to be satisfied by the foci, and
-- @mod@ is the modification to be applied to the selected foci.
selectP :: (a -> Bool) -> Prism' a a
selectP :: forall a. (a -> Bool) -> Prism' a a
selectP a -> Bool
prop = (a -> a) -> (a -> Maybe a) -> Prism a a a a
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' a -> a
forall a. a -> a
id (\a
a -> if a -> Bool
prop a
a then a -> Maybe a
forall a. a -> Maybe a
Just a
a else Maybe a
forall a. Maybe a
Nothing)