A Failover effect, like Choose but with laws like Maybe's Alternative instance

Failover.hs

import Control.Algebra

-- Failover effect

failover :: Has Failover sig m => m a -> m a -> m a
failover a b = send (Failover a b)

infixl 3 `failover`

data Failover m k where
  Failover :: m a -> m a -> Failover m a


-- Failover data

-- | Case analysis for 'Branch'.
branch :: (a -> b) -> (a -> b) -> Branch a -> b
branch fail pass = \case
  Fail a -> fail a
  Pass a -> pass a

fromBranch :: Branch a -> a
fromBranch = branch id id

data Branch a = Fail a | Pass a
  deriving (Functor)

instance Applicative Branch where
  pure = Pass
  Pass f <*> Pass a = Pass (f a)
  f <*> a           = Fail (fromBranch f (fromBranch a))

instance Monad Branch where
  a >>= k = k (fromBranch a)

instance Algebra Failover Branch where
  alg hdl (Failover a b) ctx = branch (hdl . (b <$)) Pass (hdl (a <$ ctx))


-- Failover carrier

runFailover :: Functor m => FailoverC m a -> m a
runFailover (FailoverC m) = branch id id <$> m

newtype FailoverC m a = FailoverC { runFailoverC :: m (Branch a) }
  deriving (Functor)

instance Applicative m => Applicative (FailoverC m) where
  pure a = FailoverC (pure (Pass a))
  FailoverC f <*> FailoverC a = FailoverC ((<*>) <$> f <*> a)

instance Monad m => Monad (FailoverC m) where
  FailoverC m >>= k = FailoverC (m >>= branch (runFailoverC . k) (runFailoverC . k))

instance Algebra sig m => Algebra (Failover :+: sig) (FailoverC m) where
  alg hdl sig ctx = FailoverC $ case sig of
    L (Failover a b) -> do
      a' <- runFailoverC (hdl (a <$ ctx))
      branch (runFailoverC . hdl . (b <$)) (pure . Pass) a'
    R other          -> thread (branch runFailoverC runFailoverC ~<~ hdl) other (Pass ctx)