Skip to content

Instantly share code, notes, and snippets.

@robrix
Last active June 26, 2022 12:27
Show Gist options
  • Save robrix/ad37d8f31cf8c568263b61090b219593 to your computer and use it in GitHub Desktop.
Save robrix/ad37d8f31cf8c568263b61090b219593 to your computer and use it in GitHub Desktop.
A Failover effect, like Choose but with laws like Maybe's Alternative instance
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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment