module Control.Monad.Signal.Class
( MonadSignal(..), handleOne, Subset', handleAll, throwAllSignals, errorAllSignals
, liftSignals, SignalT(..), Signal(..) ) where
import Data.Union hiding (left, right)
import Data.Functor.Identity
import Control.Monad.Signal hiding (signal, handle, liftSignal, handleOne)
import qualified Control.Monad.Signal as Signal
import Control.Monad.Trans
import Control.Monad.Trans.State
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Either
import Control.Exception (Exception, throwIO)
import GHC.Base
import Unsafe.Coerce
import Data.Proxy
class Monad m => MonadSignal sigs m | m -> sigs where
signal :: Elem sigs s => s -> m a
signal = signalUnion . liftSingle
signalUnion :: Union sigs -> m a
handleOne :: MonadSignal sigs m => (s -> m b) -> (a -> m b) -> EitherT s m a -> m b
handleOne = eitherT
instance MonadSignal sigs m => MonadSignal (s ': sigs) (EitherT s m) where
signalUnion (Union (Right x)) = left x
signalUnion (Union (Left u)) = lift $ signalUnion u
instance Monad m => MonadSignal sigs (SignalT sigs m) where
signalUnion = SignalT . pure . Signal
instance MonadSignal sigs (Signal sigs) where
signal = Signal.signal
signalUnion = Signal
instance MonadSignal sigs m => MonadSignal sigs (MaybeT m) where
signal = lift . signal
signalUnion = lift . signalUnion
instance MonadSignal sigs m => MonadSignal sigs (ReaderT r m) where
signal = lift . signal
signalUnion = lift . signalUnion
instance (MonadSignal sigs m, Monoid w) => MonadSignal sigs (WriterT w m) where
signal = lift . signal
signalUnion = lift . signalUnion
instance MonadSignal sigs m => MonadSignal sigs (StateT s m) where
signal = lift . signal
signalUnion = lift . signalUnion
instance MonadSignal sigs m => MonadSignal sigs (ContT r m) where
signal = lift . signal
signalUnion = lift . signalUnion
instance MonadSignal '[] IO where
signal _ = error "Apparently the assumption that Elem '[] s can't be satisfied is wrong"
signalUnion = absurd
type family Subset' (as :: [*]) (bs :: [*]) :: Constraint where
Subset' '[] bs = ()
Subset' (a ': as) bs = (Elem bs a, Subset' as bs)
handleAll :: (Monad m, All c sigs)
=> proxy c -> (forall x. c x => x -> m a) -> SignalT sigs m a -> m a
handleAll p f (SignalT ms) = ms >>= f'
where f' (Value a) = pure a
f' (Signal u) = deconstructAll p u f
throwAllSignals :: (MonadIO m, All Exception sigs) => SignalT sigs m a -> m a
throwAllSignals = handleAll (Proxy :: Proxy Exception) (liftIO . throwIO)
errorAllSignals :: (Monad m, All Show sigs) => SignalT sigs m a -> m a
errorAllSignals = handleAll (Proxy :: Proxy Show) (error . show)
liftSignals :: forall sigs sigs' m a. (All (Elem sigs') sigs, MonadSignal sigs' m)
=> SignalT sigs m a -> m a
liftSignals = handleAll (Proxy :: Proxy (Elem sigs')) signal