Effects.hs

module Union where

import Control.Monad
import qualified Control.Monad.Reader as MTL

data Union fs (m :: * -> *) x where
  Here  :: f m x -> Union (f : fs) m x
  There :: Union fs m x -> Union (f : fs) m x

elimUnion :: (f m a -> c) -> (Union fs m a -> c) -> Union (f : fs) m a -> c
elimUnion f g (Here  x)  = f x
elimUnion f g (There xs) = g xs

class Member f fs where
  inject  :: f m x -> Union fs m x
  project :: Union fs m x -> Maybe (f m x)

instance {-# overlaps #-} Member f (f : fs) where
  inject = Here
  project (Here f) = Just f
  project  _       = Nothing

instance Member f fs => Member f (g : fs) where
  inject = There . inject
  project (There fs) = project fs
  project  _         = Nothing

newtype Eff fs a = Eff { unEff :: forall m g. (Monad m, Monad g, Traversable g) => (forall b. Union fs (Eff fs) b -> m (g b)) -> m (g a) }

instance Functor (Eff fs) where
  fmap = liftM

instance Applicative (Eff fs) where
  pure x = Eff (\_ -> pure (pure x))
  (<*>)  = ap

instance Monad (Eff fs) where
  Eff run >>= callb = Eff \h -> do
    a <- run h
    fmap join $ traverse (\a' -> unEff (callb a') h) a

instance Functor (Union '[] m) where
  fmap _ = \case

instance (Functor (Union fs m), Functor (f m)) => Functor (Union (f : fs) m) where
  fmap f = \case
    Here x -> Here $ fmap f x
    There xs -> There $ fmap f xs

type f ~> g = forall a. f a -> g a

type Effects fs = Functor (Union fs (Eff fs))

send :: (Member f fs, Effects fs) => f (Eff fs) ~> Eff fs
send f = Eff ($ inject f)

class Effect f where
  weave :: (n a -> m b) -> (f n a -> f m b)

instance Effect (Union '[]) where
  weave _ = \case

instance (Effect (Union fs), Effect f) => Effect (Union (f : fs)) where
  weave f = \case
    Here x -> Here $ weave f x
    There xs -> There $ weave f xs

plug
  :: forall f fs g b
  .  (Effect f, Effect (Union fs), Monad g, Traversable g)
  => (forall a. f  (Eff fs) a -> Eff fs (g a))
  -> Eff (f : fs) b -> Eff fs (g b)
plug handler eff = unEff eff \case
  Here  f  -> fmap join $ handler $ weave (plug handler) f
  There fs -> Eff ($ weave (plug handler) fs)

data Reader e m a where
  Ask   :: Reader e m e
  Local :: (e -> e) -> m a -> Reader e m a
  Pure  :: a -> Reader e m a
  Bind  :: Reader e m a -> (a -> Reader e m b) -> Reader e m b

instance Effect (Reader e) where
  weave f Ask = Ask `Bind` _

ask :: (Member (Reader e) fs, Effects fs) => Eff fs e
ask = send Ask

local :: (Member (Reader e) fs, Effects fs) => (e -> e) -> Eff fs a -> Eff fs a
local f ma = send (Local f ma)

runReader :: Effects fs => Eff (Reader e : fs) a -> Eff fs (MTL.Reader e a)
runReader = plug _