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

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 Swarm.Game.Failure (SystemFailure)
import Swarm.Language.Pretty (prettyString)
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 = forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. e1 -> e2
f) 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. Either a b -> Maybe b
eitherToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- 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 -> forall w (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Accum (Seq w)) sig m =>
w -> m ()
warn e
err forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 = forall (m :: * -> *) w a. Functor m => w -> AccumC w m a -> m a
evalAccum 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 = forall w (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Accum w) sig m =>
w -> m ()
add forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
  forall (t :: * -> *) (f :: * -> *) a b.
(Witherable t, Applicative f) =>
(a -> f (Maybe b)) -> t a -> f (t b)
wither forall a b. (a -> b) -> a -> b
$
    a -> m (Either w b)
f forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
      Left w
e -> forall w (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Accum (Seq w)) sig m =>
w -> m ()
warn w
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Right b
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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

simpleErrorHandle :: ThrowC SystemFailure IO a -> IO a
simpleErrorHandle :: forall a. ThrowC SystemFailure IO a -> IO a
simpleErrorHandle = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrettyPrec a => a -> String
prettyString) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow