{-# LANGUAGE FunctionalDependencies, DataKinds, TypeFamilies, FlexibleContexts, FlexibleInstances
           , TypeOperators, ScopedTypeVariables, UndecidableInstances, KindSignatures
           , NoMonomorphismRestriction, Rank2Types, ConstraintKinds #-}
-- | Some sample usage could look like this.
--
-- >    sample :: (Subset' '[Int, String] sigs, MonadSignal sigs m, MonadIO m) => m ()
-- >    sample = do
-- >        liftIO (putStrLn "Signaling 1")
-- >        signal (1 :: Int)
-- >        liftIO (putStrLn "Signaling asd")
-- >        signal "asd"
-- >
-- >    sample' :: (MonadSignal '[Int, String] m, MonadIO m) => m ()
-- >    sample' = handleOne (\(i :: String) -> liftIO (putStrLn i) >> signal i) return sample
--
--   You can then try @errorAllSignals sample'@ in GHCi to see what happens. Then try commenting out
--   the @signal (1 :: Int)@ line.
--
--   Notice that both functions are polymorphic in the monad they're running in.
--   The @handleOne@ function discards one signal from the constraint on @m@ by extracting it
--   into an @EitherT@ and it leaves the rest of them in the polymorphic underlying monad.
--   This lets us write MTL style code while still being able to do insteresting things with
--   the types.

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

-- | A class of monads that can signal a value with a type from some fixed set of types.
--   Implementing instances for any transformer should be as easy as
--
-- >     signal = lift . signal
-- >     signalUnion = lift . signalUnion
class Monad m => MonadSignal sigs m | m -> sigs where
    signal :: Elem sigs s => s -> m a
    signal = signalUnion . liftSingle
    signalUnion :: Union sigs -> m a

-- | Handle a single signal. This function takes an EitherT but since there's a MonadSignal
--   instance for EitherT it's very easy to use if your functions are polymorphic over monads.
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

-- | Basically @Subset' '[a1, a2,...] bs@ is an alias for @(Elem a1 bs, Elem a2 bs,...)@
type family Subset' (as :: [*]) (bs :: [*]) :: Constraint where
    Subset' '[] bs = ()
    Subset' (a ': as) bs = (Elem bs a, Subset' as bs)


-- | If all the elements of @sigs@ satisfy the @c@ constraint then, given a function that only cares
--   about that constraint type, we can colapse the signal transformer into the underlying monad.
--
--   For example, if all the types in @sigs@ satisfy the @Show@ class, then we can use the @show@
--   function to turn a @SignalT sigs m String@ into a @m String@.
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

-- | If all the signals are exceptions, we can throw them as IO exceptions.
throwAllSignals :: (MonadIO m, All Exception sigs) => SignalT sigs m a -> m a
throwAllSignals = handleAll (Proxy :: Proxy Exception) (liftIO . throwIO)

-- | If all the signals are showable we can crash with an error for any of them.
errorAllSignals :: (Monad m, All Show sigs) => SignalT sigs m a -> m a
errorAllSignals = handleAll (Proxy :: Proxy Show) (error . show)

-- | This is useful if we have a function like @MonadSignal '[A, B] m => m ()@ and we want to use
--   it in something like @MonadSignal '[B, C, A] m => m ()@.
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