-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- fused-effect utilities for Swarm.
module Swarm.Util.Effect where

import Control.Algebra
import Control.Carrier.Accum.FixedStrict
import Control.Carrier.Error.Either (ErrorC (..))
import Control.Carrier.Throw.Either (ThrowC (..), runThrow)
import Control.Effect.Throw
import Control.Monad ((>=>))
import Control.Monad.Trans.Except (ExceptT)
import Data.Either.Extra (eitherToMaybe)
import Data.Sequence (Seq)
import Data.Sequence qualified as Seq
import Witherable

-- | Transform a @Throw e1@ constraint into a @Throw e2@ constraint,
--   by supplying an adapter function of type @(e1 -> e2)@.
withThrow :: (Has (Throw e2) sig m) => (e1 -> e2) -> ThrowC e1 m a -> m a
withThrow :: forall e2 (sig :: (* -> *) -> * -> *) (m :: * -> *) e1 a.
Has (Throw e2) sig m =>
(e1 -> e2) -> ThrowC e1 m a -> m a
withThrow e1 -> e2
f = ThrowC e1 m a -> m (Either e1 a)
forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow (ThrowC e1 m a -> m (Either e1 a))
-> (Either e1 a -> m a) -> ThrowC e1 m a -> m a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (e1 -> m a) -> (a -> m a) -> Either e1 a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (e2 -> m a
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (e2 -> m a) -> (e1 -> e2) -> e1 -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e1 -> e2
f) a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Transform a @Throw e@ constrint into a concrete @Maybe@,
--   discarding the error.
throwToMaybe :: forall e m a. Functor m => ThrowC e m a -> m (Maybe a)
throwToMaybe :: forall e (m :: * -> *) a. Functor m => ThrowC e m a -> m (Maybe a)
throwToMaybe = (Either e a -> Maybe a) -> m (Either e a) -> m (Maybe a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either e a -> Maybe a
forall a b. Either a b -> Maybe b
eitherToMaybe (m (Either e a) -> m (Maybe a))
-> (ThrowC e m a -> m (Either e a)) -> ThrowC e m a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThrowC e m a -> m (Either e a)
forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow

-- | Transform a @Throw e@ constrint into a concrete @Maybe@,
--   logging any error as a warning.
throwToWarning :: (Has (Accum (Seq e)) sig m) => ThrowC e m a -> m (Maybe a)
throwToWarning :: forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Accum (Seq e)) sig m =>
ThrowC e m a -> m (Maybe a)
throwToWarning ThrowC e m a
m = do
  Either e a
res <- ThrowC e m a -> m (Either e a)
forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow ThrowC e m a
m
  case Either e a
res of
    Left e
err -> e -> m ()
forall w (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Accum (Seq w)) sig m =>
w -> m ()
warn e
err m () -> m (Maybe a) -> m (Maybe a)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Right a
a -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a)

-- | Run a computation with an @Accum@ effect (typically accumulating
--   a list of warnings), ignoring the accumulated value.
ignoreWarnings :: forall e m a. (Monoid e, Functor m) => AccumC e m a -> m a
ignoreWarnings :: forall e (m :: * -> *) a.
(Monoid e, Functor m) =>
AccumC e m a -> m a
ignoreWarnings = e -> AccumC e m a -> m a
forall (m :: * -> *) w a. Functor m => w -> AccumC w m a -> m a
evalAccum e
forall a. Monoid a => a
mempty

-- | Convert a fused-effects style computation using a @Throw e@
--   constraint into an @ExceptT@ computation.  This is mostly a stub
--   to convert from one style to the other while we are in the middle
--   of incrementally converting.  Eventually this should not be needed.
asExceptT :: ThrowC e m a -> ExceptT e m a
asExceptT :: forall e (m :: * -> *) a. ThrowC e m a -> ExceptT e m a
asExceptT (ThrowC (ErrorC ExceptT e m a
m)) = ExceptT e m a
m

-- | Log a single failure as a warning.
warn :: Has (Accum (Seq w)) sig m => w -> m ()
warn :: forall w (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Accum (Seq w)) sig m =>
w -> m ()
warn = Seq w -> m ()
forall w (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Accum w) sig m =>
w -> m ()
add (Seq w -> m ()) -> (w -> Seq w) -> w -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Seq w
forall a. a -> Seq a
Seq.singleton

-- | A version of 'traverse'/'mapM' that also accumulates warnings.
--
--   Note that we can't generalize this to work over any 'Traversable'
--   because it also needs to have a notion of "filtering".
--   'Witherable' provides exactly the right abstraction.
traverseW ::
  (Has (Accum (Seq w)) sig m, Witherable t) =>
  (a -> m (Either w b)) ->
  t a ->
  m (t b)
traverseW :: forall w (sig :: (* -> *) -> * -> *) (m :: * -> *) (t :: * -> *) a
       b.
(Has (Accum (Seq w)) sig m, Witherable t) =>
(a -> m (Either w b)) -> t a -> m (t b)
traverseW a -> m (Either w b)
f = do
  (a -> m (Maybe b)) -> t a -> m (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Witherable t, Applicative f) =>
(a -> f (Maybe b)) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f (Maybe b)) -> t a -> f (t b)
wither ((a -> m (Maybe b)) -> t a -> m (t b))
-> (a -> m (Maybe b)) -> t a -> m (t b)
forall a b. (a -> b) -> a -> b
$
    a -> m (Either w b)
f (a -> m (Either w b))
-> (Either w b -> m (Maybe b)) -> a -> m (Maybe b)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
      Left w
e -> w -> m ()
forall w (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Accum (Seq w)) sig m =>
w -> m ()
warn w
e m () -> m (Maybe b) -> m (Maybe b)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe b -> m (Maybe b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
      Right b
e -> Maybe b -> m (Maybe b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b -> m (Maybe b)) -> Maybe b -> m (Maybe b)
forall a b. (a -> b) -> a -> b
$ b -> Maybe b
forall a. a -> Maybe a
Just b
e

-- | Flipped version of 'traverseW' for convenience.
forMW ::
  (Has (Accum (Seq w)) sig m, Witherable t) =>
  t a ->
  (a -> m (Either w b)) ->
  m (t b)
forMW :: forall w (sig :: (* -> *) -> * -> *) (m :: * -> *) (t :: * -> *) a
       b.
(Has (Accum (Seq w)) sig m, Witherable t) =>
t a -> (a -> m (Either w b)) -> m (t b)
forMW = ((a -> m (Either w b)) -> t a -> m (t b))
-> t a -> (a -> m (Either w b)) -> m (t b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> m (Either w b)) -> t a -> m (t b)
forall w (sig :: (* -> *) -> * -> *) (m :: * -> *) (t :: * -> *) a
       b.
(Has (Accum (Seq w)) sig m, Witherable t) =>
(a -> m (Either w b)) -> t a -> m (t b)
traverseW