{-# LANGUAGE TypeFamilies, ScopedTypeVariables, FlexibleContexts, Rank2Types, ConstraintKinds #-}
{-# LANGUAGE MultiParamTypeClasses, NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances, DataKinds, TypeOperators #-}
{-# LANGUAGE GADTs, DeriveGeneric #-}
{-# LANGUAGE InstanceSigs #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Control.Effects.Signal
( ResumeOrBreak(..), Signal(..), throwSignal, handleSignal
, Throw, handleException, handleToEither, module Control.Effects
, module Control.Monad.Trans.Except, MaybeT(..), discardAllExceptions, showAllExceptions
, HandleException(..), handleWithoutDiscarding, handleToEitherRecursive, SomeSignal
, signal ) where
import Import hiding (liftThrough)
import Control.Monad.Trans.Except
import qualified GHC.TypeLits as TL
import GHC.TypeLits (TypeError, ErrorMessage(..))
import Control.Effects
import Control.Monad.Runnable
import GHC.Generics
newtype Signal a b m = SignalMethods
{ _signal :: a -> m b }
deriving (Generic)
instance Effect (Signal a b) where
signal :: forall a b m. MonadEffect (Signal a b) m => a -> m b
SignalMethods signal = effect
newtype SomeSignal = SomeSignal { getSomeSignal :: Text } deriving (Eq, Ord, Read, Show)
type family UnhandledError a b :: ErrorMessage where
UnhandledError a Void =
'TL.Text "Unhandled exception of type " ':<>: 'ShowType a
':$$: 'TL.Text "You need to handle all the exceptions before running the computation"
UnhandledError a b =
'TL.Text "Unhandled signal of type " ':<>: 'ShowType a
':<>: 'TL.Text " expecting a return value of type " ':<>: 'ShowType b
':$$: 'TL.Text "You need to handle all the signals before running the computation"
instance {-# OVERLAPPABLE #-} Monad m => MonadEffect (Signal e b) (ExceptT e m) where
effect = SignalMethods throwE
instance (Show e, Monad m) => MonadEffect (Signal e b) (ExceptT SomeSignal m) where
effect = SignalMethods (throwE . SomeSignal . pack . show)
instance Monad m => MonadEffect (Signal a b) (MaybeT m) where
effect = SignalMethods (const mzero)
instance TypeError (UnhandledError a b) => MonadEffect (Signal a b) IO where
effect = undefined
instance {-# INCOHERENT #-} (Monad m, b ~ c) =>
MonadEffect (Signal a c) (RuntimeImplemented (Signal a b) m) where
effect = mergeContext $ RuntimeImplemented (liftThrough <$> ask)
type Throw e = Signal e Void
data ResumeOrBreak b c =
Resume b
| Break c
throwSignal :: MonadEffect (Throw a) m => a -> m b
throwSignal = fmap absurd . signal
resumeOrBreak :: (b -> a) -> (c -> a) -> ResumeOrBreak b c -> a
resumeOrBreak ba _ (Resume b) = ba b
resumeOrBreak _ ca (Break c) = ca c
collapseEither :: Either a a -> a
collapseEither (Left a) = a
collapseEither (Right a) = a
handleSignal :: forall a b c m. Monad m
=> (a -> m (ResumeOrBreak b c))
-> RuntimeImplemented (Signal a b) (ExceptT c m) c
-> m c
handleSignal f = fmap collapseEither
. runExceptT
. implement (SignalMethods h)
where
h a = do
rb <- lift (f a)
resumeOrBreak return throwE rb
handleException :: forall a c m. Monad m => (a -> m c) -> ExceptT a m c -> m c
handleException f = either f return <=< runExceptT
handleToEither :: forall e a m. ExceptT e m a -> m (Either e a)
handleToEither = runExceptT
discardAllExceptions :: MaybeT m a -> m (Maybe a)
discardAllExceptions = runMaybeT
mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft f (Left a) = Left (f a)
mapLeft _ (Right b) = Right b
showAllExceptions :: Functor m => ExceptT SomeSignal m a -> m (Either Text a)
showAllExceptions = fmap (mapLeft getSomeSignal) . runExceptT
newtype HandleException e m = HandleExceptionMethods
{ _handleWithoutDiscarding :: forall a. (e -> m a) -> m a -> m a }
instance Effect (HandleException e) where
type CanLift (HandleException e) t = RunnableTrans t
liftThrough ::
forall t m. (CanLift (HandleException e) t, Monad m, Monad (t m))
=> HandleException e m -> HandleException e (t m)
liftThrough (HandleExceptionMethods rec') = HandleExceptionMethods $ \f e -> do
st <- currentTransState
res <- lift (rec' (\ex -> runTransformer (f ex) st) (runTransformer e st))
restoreTransState res
mergeContext m = HandleExceptionMethods $ \f ex -> do
g <- _handleWithoutDiscarding <$> m
g f ex
handleWithoutDiscarding ::
forall e m a. MonadEffect (HandleException e) m => (e -> m a) -> m a -> m a
HandleExceptionMethods handleWithoutDiscarding = effect
instance Monad m => MonadEffect (HandleException e) (ExceptT e m) where
effect = HandleExceptionMethods $ \f ->
ExceptT . (either (runExceptT . f) (return . Right) <=< runExceptT)
handleToEitherRecursive :: MonadEffect (HandleException e) m => m a -> m (Either e a)
handleToEitherRecursive = handleWithoutDiscarding (return . Left) . fmap Right