{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
module Control.Eff.Internal where
import qualified Control.Arrow as A
import qualified Control.Category as C
import Control.Monad.Base (MonadBase(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Control (MonadBaseControl(..))
import qualified Control.Exception as Exc
import safe Data.OpenUnion
import safe Data.FTCQueue
import GHC.Exts (inline)
import Data.Function (fix)
type Arr r a b = a -> Eff r b
newtype Arrs r a b = Arrs (FTCQueue (Eff r) a b)
instance C.Category (Arrs r) where
id = ident
f . g = comp g f
instance A.Arrow (Arrs r) where
arr = arr
first = singleK . first . (^$)
first :: Arr r a b -> Arr r (a, c) (b, c)
first x = \(a,c) -> (, c) `fmap` x a
{-# INLINE singleK #-}
singleK :: Arr r a b -> Arrs r a b
singleK = Arrs . tsingleton
{-# INLINE (~^) #-}
(~^) :: Arr r a b -> Arrs r a b
(~^) = singleK
{-# INLINABLE qApp #-}
qApp :: forall r b w. Arrs r b w -> Arr r b w
qApp (Arrs q) x = viewlMap (inline tviewl q) ($ x) cons
where
cons :: forall x. Arr r b x -> FTCQueue (Eff r) x w -> Eff r w
cons = \k t -> case k x of
Val y -> qApp (Arrs t) y
E (Arrs q0) u -> E (Arrs (q0 >< t)) u
{-# INLINABLE (^$) #-}
(^$) :: forall r b w. Arrs r b w -> Arr r b w
q ^$ x = q `qApp` x
arr :: (a -> b) -> Arrs r a b
arr f = singleK (Val . f)
ident :: Arrs r a a
ident = arr id
comp :: Arrs r a b -> Arrs r b c -> Arrs r a c
comp (Arrs f) (Arrs g) = Arrs (f >< g)
(^|>) :: Arrs r a b -> Arr r b c -> Arrs r a c
(Arrs f) ^|> g = Arrs (f |> g)
data Eff r a = Val a
| forall b. E (Arrs r b a) (Union r b)
{-# INLINE eff #-}
eff :: (a -> b)
-> (forall v. Arrs r v a -> Union r v -> b)
-> Eff r a -> b
eff f _ (Val a) = f a
eff _ g (E q u) = g q u
{-# INLINE bind #-}
bind :: Arr r a b -> Eff r a -> Eff r b
bind k = eff k (E . (^|> k))
{-# INLINE impureDecomp #-}
impureDecomp :: (Arrs (t ': r) v a -> t v -> b)
-> (Arrs (t ': r) v a -> Union r v -> b)
-> Arrs (t ': r) v a -> Union (t ': r) v -> b
impureDecomp h rest q u = either (rest q) (h q) (decomp u)
{-# INLINE impurePrj #-}
impurePrj :: Member t r
=> (Arrs r v a -> t v -> b)
-> (Arrs r v a -> Union r v -> b)
-> Arrs r v a -> Union r v -> b
impurePrj h def q u = maybe (def q u) (h q) (prj u)
{-# INLINE qComp #-}
qComp :: Arrs r a b -> (Eff r b -> k) -> (a -> k)
qComp g h = \a -> h $ (g ^$ a)
{-# INLINABLE qThen #-}
qThen :: (Eff r b -> k) -> Arrs r a b -> (a -> k)
qThen = flip qComp
andThen :: ((b -> c) -> t) -> (Eff r w -> c)
-> Arrs r b w -> t
andThen f next = f . (qThen next)
{-# INLINE qComps #-}
qComps :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arrs r' a c
qComps g h = singleK $ qComp g h
{-# INLINABLE (^|$^) #-}
(^|$^) :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arrs r' a c
(^|$^) = qComps
instance Functor (Eff r) where
{-# INLINE fmap #-}
fmap f = bind (Val . f)
instance Applicative (Eff r) where
{-# INLINE pure #-}
pure = Val
mf <*> e = bind (`fmap` e) mf
instance Monad (Eff r) where
{-# INLINE return #-}
{-# INLINE [2] (>>=) #-}
return = pure
(>>=) = flip bind
{-# INLINE [2] send #-}
send :: Member t r => t v -> Eff r v
send t = E (singleK Val) (inj t)
{-# RULES
"send/bind" [~3] forall t k. send t >>= k = E (singleK k) (inj t)
#-}
run :: Eff '[] w -> w
run (Val x) = x
run (E _ union) =
union `seq` error "extensible-effects: the impossible happened!"
class Relay k r where
relay :: (v -> k) -> Union r v -> k
instance Relay (Eff r w) r where
relay q u = E (singleK q) u
instance Relay k r => Relay (s -> k) r where
relay q u s = relay (\x -> q x s) u
class Handle t k where
handle :: (v -> k) -> t v -> k
handle_relay :: forall t k r a. Handle t k => Relay k r
=> (a -> k)
-> Eff (t ': r) a -> k
handle_relay ret = handle_relay' ret handle
handle_relay' :: forall t k r a. Relay k r
=> (a -> k)
-> (forall v. (v -> k) -> t v -> k)
-> Eff (t ': r) a -> k
handle_relay' ret h = fix step
where
step next = eff ret
(impureDecomp
(h `andThen` next)
(relay `andThen` next))
respond_relay :: Member t r => Relay k r
=> (a -> k)
-> (forall v. (v -> k) -> t v -> k)
-> Eff r a -> k
respond_relay ret h = fix step
where
step next = eff ret
(impurePrj
(h `andThen` next)
(relay `andThen` next))
respond_relay' :: forall t k r a. (Member t r, Handle t k, Relay k r)
=> (a -> k)
-> Eff r a -> k
respond_relay' ret = respond_relay ret (handle @t)
raise :: Eff r a -> Eff (e ': r) a
raise = fix step
where
step next = eff pure
(\q -> ((E . (~^) . (qThen next)) q) . weaken)
{-# INLINE raise #-}
newtype Lift m a = Lift { unLift :: m a }
type Lifted m r = SetMember Lift (Lift m) r
type LiftedBase m r = ( SetMember Lift (Lift m) r
, MonadBaseControl m (Eff r)
)
lift :: Lifted m r => m a -> Eff r a
lift = send . Lift
instance Monad m => Handle (Lift m) (m k) where
handle k (Lift x) = x >>= k
runLift :: Monad m => Eff '[Lift m] w -> m w
runLift = fix step
where
step :: Monad m => (Eff '[Lift m] w -> m w) -> Eff '[Lift m] w -> m w
step next = eff return
(impurePrj
(handle `andThen` next)
(\_ _ -> error "Impossible: Nothing to relay!")
)
catchDynE :: forall e a r.
(Lifted IO r, Exc.Exception e) =>
Eff r a -> (e -> Eff r a) -> Eff r a
catchDynE m eh = respond_relay return h m
where
h :: Arr r v a -> Lift IO v -> Eff r a
h k (Lift em) = lift (Exc.try em) >>= either eh k
data HandlerDynE r a =
forall e. (Exc.Exception e, Lifted IO r) => HandlerDynE (e -> Eff r a)
catchesDynE :: Lifted IO r => Eff r a -> [HandlerDynE r a] -> Eff r a
catchesDynE m hs = m `catchDynE` catchesHandler hs where
catchesHandler :: Lifted IO r => [HandlerDynE r a] -> Exc.SomeException -> Eff r a
catchesHandler handlers e = foldr tryHandler (lift . Exc.throw $ e) handlers
where
tryHandler (HandlerDynE h) res = maybe res h (Exc.fromException e)
instance (MonadBase b m, Lifted m r) => MonadBase b (Eff r) where
liftBase = lift . liftBase
{-# INLINE liftBase #-}
instance (MonadBase m m) => MonadBaseControl m (Eff '[Lift m]) where
type StM (Eff '[Lift m]) a = a
liftBaseWith f = lift (f runLift)
{-# INLINE liftBaseWith #-}
restoreM = return
{-# INLINE restoreM #-}
instance (MonadIO m, Lifted m r) => MonadIO (Eff r) where
liftIO = lift . liftIO
{-# INLINE liftIO #-}