{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Extensible.Effect.Default
-- Copyright   :  (c) Fumiaki Kinoshita 2018
-- License     :  BSD3
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--
-- Default monad runners and 'MonadIO', 'MonadReader', 'MonadWriter',
-- 'MonadState', 'MonadError' instances
-----------------------------------------------------------------------------
module Data.Extensible.Effect.Default (
  runIODef
  , ReaderDef
  , runReaderDef
  , StateDef
  , runStateDef
  , evalStateDef
  , execStateDef
  , WriterDef
  , runWriterDef
  , execWriterDef
  , MaybeDef
  , runMaybeDef
  , EitherDef
  , runEitherDef
  , ContDef
  , runContDef
) where
import Control.Applicative
import Data.Extensible.Effect
import Control.Monad.Except
import Control.Monad.Catch
import Control.Monad.Cont
import Control.Monad.Reader.Class
import Control.Monad.Skeleton
import Control.Monad.State.Strict
#if MIN_VERSION_resourcet(1,2,0)
import Control.Monad.Trans.Resource
#endif
import Control.Monad.Writer.Class
import Data.Type.Equality
import Type.Membership

instance (MonadIO m, Lookup xs "IO" m) => MonadIO (Eff xs) where
  liftIO :: IO a -> Eff xs a
liftIO = Proxy "IO" -> m a -> Eff xs a
forall k (s :: k) (t :: * -> *) (xs :: [Assoc k (* -> *)]) a.
Lookup xs s t =>
Proxy s -> t a -> Eff xs a
liftEff (Proxy "IO"
forall k (t :: k). Proxy t
Proxy :: Proxy "IO") (m a -> Eff xs a) -> (IO a -> m a) -> IO a -> Eff xs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | 'retractEff' specialised for IO
runIODef :: Eff '["IO" ':> IO] a -> IO a
runIODef :: Eff '[ "IO" ':> IO] a -> IO a
runIODef = Eff '[ "IO" ':> IO] a -> IO a
forall k1 (k2 :: k1) (m :: * -> *) a.
Monad m =>
Eff '[k2 >: m] a -> m a
retractEff

#if MIN_VERSION_resourcet(1,2,0)
instance (MonadResource m, Lookup xs "IO" m) => MonadResource (Eff xs) where
  liftResourceT :: ResourceT IO a -> Eff xs a
liftResourceT = Proxy "IO" -> m a -> Eff xs a
forall k (s :: k) (t :: * -> *) (xs :: [Assoc k (* -> *)]) a.
Lookup xs s t =>
Proxy s -> t a -> Eff xs a
liftEff (Proxy "IO"
forall k (t :: k). Proxy t
Proxy :: Proxy "IO") (m a -> Eff xs a)
-> (ResourceT IO a -> m a) -> ResourceT IO a -> Eff xs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceT IO a -> m a
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT
#endif

instance (MonadThrow m, Lookup xs "IO" m) => MonadThrow (Eff xs) where
  throwM :: e -> Eff xs a
throwM = Proxy "IO" -> m a -> Eff xs a
forall k (s :: k) (t :: * -> *) (xs :: [Assoc k (* -> *)]) a.
Lookup xs s t =>
Proxy s -> t a -> Eff xs a
liftEff (Proxy "IO"
forall k (t :: k). Proxy t
Proxy :: Proxy "IO") (m a -> Eff xs a) -> (e -> m a) -> e -> Eff xs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM

instance (MonadCatch m, Lookup xs "IO" m) => MonadCatch (Eff xs) where
  catch :: Eff xs a -> (e -> Eff xs a) -> Eff xs a
catch Eff xs a
m0 e -> Eff xs a
h = Eff xs a -> Eff xs a
go Eff xs a
m0 where
    go :: Eff xs a -> Eff xs a
go Eff xs a
m = case Eff xs a -> MonadView (Instruction xs) (Eff xs) a
forall (t :: * -> *) a. Skeleton t a -> MonadView t (Skeleton t) a
debone Eff xs a
m of
      Return a
a -> a -> Eff xs a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
      Instruction i t :>>= a -> Eff xs a
k -> case Membership xs ("IO" ':> m)
-> Membership xs kv -> Either Ordering (("IO" ':> m) :~: kv)
forall k (xs :: [k]) (x :: k) (y :: k).
Membership xs x -> Membership xs y -> Either Ordering (x :~: y)
compareMembership (Membership xs ("IO" ':> m)
forall k k1 (xs :: [Assoc k k1]) (k2 :: k) (v :: k1).
Lookup xs k2 v =>
Membership xs (k2 ':> v)
association :: Membership xs ("IO" ':> m)) Membership xs kv
i of
        Left Ordering
_ -> MonadView (Instruction xs) (Eff xs) a -> Eff xs a
forall (t :: * -> *) a. MonadView t (Skeleton t) a -> Skeleton t a
boned (MonadView (Instruction xs) (Eff xs) a -> Eff xs a)
-> MonadView (Instruction xs) (Eff xs) a -> Eff xs a
forall a b. (a -> b) -> a -> b
$ Membership xs kv -> TargetOf kv a -> Instruction xs a
forall k (xs :: [Assoc k (* -> *)]) (kv :: Assoc k (* -> *)) a.
Membership xs kv -> TargetOf kv a -> Instruction xs a
Instruction Membership xs kv
i TargetOf kv a
t Instruction xs a
-> (a -> Eff xs a) -> MonadView (Instruction xs) (Eff xs) a
forall (t :: * -> *) a (m :: * -> *) x.
t a -> (a -> m x) -> MonadView t m x
:>>= Eff xs a -> Eff xs a
go (Eff xs a -> Eff xs a) -> (a -> Eff xs a) -> a -> Eff xs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Eff xs a
k
        Right ("IO" ':> m) :~: kv
Refl -> MonadView (Instruction xs) (Eff xs) a -> Eff xs a
forall (t :: * -> *) a. MonadView t (Skeleton t) a -> Skeleton t a
boned (MonadView (Instruction xs) (Eff xs) a -> Eff xs a)
-> MonadView (Instruction xs) (Eff xs) a -> Eff xs a
forall a b. (a -> b) -> a -> b
$ Membership xs kv
-> TargetOf kv (Either e a) -> Instruction xs (Either e a)
forall k (xs :: [Assoc k (* -> *)]) (kv :: Assoc k (* -> *)) a.
Membership xs kv -> TargetOf kv a -> Instruction xs a
Instruction Membership xs kv
i (m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try m a
TargetOf kv a
t) Instruction xs (Either e a)
-> (Either e a -> Eff xs a)
-> MonadView (Instruction xs) (Eff xs) a
forall (t :: * -> *) a (m :: * -> *) x.
t a -> (a -> m x) -> MonadView t m x
:>>= Eff xs a -> Eff xs a
go (Eff xs a -> Eff xs a)
-> (Either e a -> Eff xs a) -> Either e a -> Eff xs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> Eff xs a) -> (a -> Eff xs a) -> Either e a -> Eff xs a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> Eff xs a
h a -> Eff xs a
k

pReader :: Proxy "Reader"
pReader :: Proxy "Reader"
pReader = Proxy "Reader"
forall k (t :: k). Proxy t
Proxy

instance Lookup xs "Reader" ((:~:) r) => MonadReader r (Eff xs) where
  ask :: Eff xs r
ask = Proxy "Reader" -> Eff xs r
forall k1 (k2 :: k1) r (xs :: [Assoc k1 (* -> *)]).
Lookup xs k2 (ReaderEff r) =>
Proxy k2 -> Eff xs r
askEff Proxy "Reader"
pReader
  local :: (r -> r) -> Eff xs a -> Eff xs a
local = Proxy "Reader" -> (r -> r) -> Eff xs a -> Eff xs a
forall k1 (k2 :: k1) r (xs :: [Assoc k1 (* -> *)]) a.
Lookup xs k2 (ReaderEff r) =>
Proxy k2 -> (r -> r) -> Eff xs a -> Eff xs a
localEff Proxy "Reader"
pReader
  reader :: (r -> a) -> Eff xs a
reader = Proxy "Reader" -> (r -> a) -> Eff xs a
forall k1 (k2 :: k1) r (xs :: [Assoc k1 (* -> *)]) a.
Lookup xs k2 (ReaderEff r) =>
Proxy k2 -> (r -> a) -> Eff xs a
asksEff Proxy "Reader"
pReader

pState :: Proxy "State"
pState :: Proxy "State"
pState = Proxy "State"
forall k (t :: k). Proxy t
Proxy

instance Lookup xs "State" (State s) => MonadState s (Eff xs) where
  get :: Eff xs s
get = Proxy "State" -> Eff xs s
forall k1 (k2 :: k1) s (xs :: [Assoc k1 (* -> *)]).
Lookup xs k2 (State s) =>
Proxy k2 -> Eff xs s
getEff Proxy "State"
pState
  put :: s -> Eff xs ()
put = Proxy "State" -> s -> Eff xs ()
forall k1 (k2 :: k1) s (xs :: [Assoc k1 (* -> *)]).
Lookup xs k2 (State s) =>
Proxy k2 -> s -> Eff xs ()
putEff Proxy "State"
pState
  state :: (s -> (a, s)) -> Eff xs a
state = Proxy "State" -> (s -> (a, s)) -> Eff xs a
forall k1 (k2 :: k1) s (xs :: [Assoc k1 (* -> *)]) a.
Lookup xs k2 (State s) =>
Proxy k2 -> (s -> (a, s)) -> Eff xs a
stateEff Proxy "State"
pState

pWriter :: Proxy "Writer"
pWriter :: Proxy "Writer"
pWriter = Proxy "Writer"
forall k (t :: k). Proxy t
Proxy

instance (Monoid w, Lookup xs "Writer" ((,) w)) => MonadWriter w (Eff xs) where
  writer :: (a, w) -> Eff xs a
writer = Proxy "Writer" -> (a, w) -> Eff xs a
forall k1 (k2 :: k1) w (xs :: [Assoc k1 (* -> *)]) a.
Lookup xs k2 (WriterEff w) =>
Proxy k2 -> (a, w) -> Eff xs a
writerEff Proxy "Writer"
pWriter
  tell :: w -> Eff xs ()
tell = Proxy "Writer" -> w -> Eff xs ()
forall k1 (k2 :: k1) w (xs :: [Assoc k1 (* -> *)]).
Lookup xs k2 (WriterEff w) =>
Proxy k2 -> w -> Eff xs ()
tellEff Proxy "Writer"
pWriter
  listen :: Eff xs a -> Eff xs (a, w)
listen = Proxy "Writer" -> Eff xs a -> Eff xs (a, w)
forall k1 (k2 :: k1) w (xs :: [Assoc k1 (* -> *)]) a.
(Lookup xs k2 (WriterEff w), Monoid w) =>
Proxy k2 -> Eff xs a -> Eff xs (a, w)
listenEff Proxy "Writer"
pWriter
  pass :: Eff xs (a, w -> w) -> Eff xs a
pass = Proxy "Writer" -> Eff xs (a, w -> w) -> Eff xs a
forall k1 (k2 :: k1) w (xs :: [Assoc k1 (* -> *)]) a.
(Lookup xs k2 (WriterEff w), Monoid w) =>
Proxy k2 -> Eff xs (a, w -> w) -> Eff xs a
passEff Proxy "Writer"
pWriter

pEither :: Proxy "Either"
pEither :: Proxy "Either"
pEither = Proxy "Either"
forall k (t :: k). Proxy t
Proxy

instance (Lookup xs "Either" (Const e)) => MonadError e (Eff xs) where
  throwError :: e -> Eff xs a
throwError = Proxy "Either" -> e -> Eff xs a
forall k1 (xs :: [Assoc k1 (* -> *)]) (k2 :: k1) e a.
Lookup xs k2 (EitherEff e) =>
Proxy k2 -> e -> Eff xs a
throwEff Proxy "Either"
pEither
  catchError :: Eff xs a -> (e -> Eff xs a) -> Eff xs a
catchError = Proxy "Either" -> Eff xs a -> (e -> Eff xs a) -> Eff xs a
forall k1 (k2 :: k1) e (xs :: [Assoc k1 (* -> *)]) a.
Lookup xs k2 (EitherEff e) =>
Proxy k2 -> Eff xs a -> (e -> Eff xs a) -> Eff xs a
catchEff Proxy "Either"
pEither

-- | A bit dubious
instance (Monoid e, Lookup xs "Either" (Const e)) => Alternative (Eff xs) where
  empty :: Eff xs a
empty = e -> Eff xs a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
forall a. Monoid a => a
mempty
  Eff xs a
p <|> :: Eff xs a -> Eff xs a -> Eff xs a
<|> Eff xs a
q = Eff xs a -> (e -> Eff xs a) -> Eff xs a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError Eff xs a
p (Eff xs a -> e -> Eff xs a
forall a b. a -> b -> a
const Eff xs a
q)

instance (Monoid e, Lookup xs "Either" (Const e)) => MonadPlus (Eff xs) where
  mzero :: Eff xs a
mzero = Eff xs a
forall (f :: * -> *) a. Alternative f => f a
empty
  mplus :: Eff xs a -> Eff xs a -> Eff xs a
mplus = Eff xs a -> Eff xs a -> Eff xs a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

pCont :: Proxy "Cont"
pCont :: Proxy "Cont"
pCont = Proxy "Cont"
forall k (t :: k). Proxy t
Proxy

instance MonadCont (Eff ((ContDef r (Eff xs)) ': xs)) where
  callCC :: ((a -> Eff (ContDef r (Eff xs) : xs) b)
 -> Eff (ContDef r (Eff xs) : xs) a)
-> Eff (ContDef r (Eff xs) : xs) a
callCC = Proxy "Cont"
-> ((a -> Eff (ContDef r (Eff xs) : xs) b)
    -> Eff (ContDef r (Eff xs) : xs) a)
-> Eff (ContDef r (Eff xs) : xs) a
forall k1 (k2 :: k1) a r (xs :: [Assoc k1 (* -> *)]) b.
Proxy k2
-> ((a -> Eff ((k2 >: ContT r (Eff xs)) : xs) b)
    -> Eff ((k2 >: ContT r (Eff xs)) : xs) a)
-> Eff ((k2 >: ContT r (Eff xs)) : xs) a
callCCEff Proxy "Cont"
pCont

-- | mtl-compatible reader
type ReaderDef r = "Reader" >: ReaderEff r

-- | Specialised version of 'runReaderEff' compatible with the 'MonadReader' instance.
runReaderDef :: Eff (ReaderDef r ': xs) a -> r -> Eff xs a
runReaderDef :: Eff (ReaderDef r : xs) a -> r -> Eff xs a
runReaderDef = Eff (ReaderDef r : xs) a -> r -> Eff xs a
forall k1 (k2 :: k1) r (xs :: [Assoc k1 (* -> *)]) a.
Eff ((k2 >: ReaderEff r) : xs) a -> r -> Eff xs a
runReaderEff
{-# INLINE runReaderDef #-}

-- | mtl-compatible state
type StateDef s = "State" >: State s

-- | 'runStateEff' specialised for the 'MonadState' instance.
runStateDef :: Eff (StateDef s ': xs) a -> s -> Eff xs (a, s)
runStateDef :: Eff (StateDef s : xs) a -> s -> Eff xs (a, s)
runStateDef = Eff (StateDef s : xs) a -> s -> Eff xs (a, s)
forall k1 (k2 :: k1) s (xs :: [Assoc k1 (* -> *)]) a.
Eff ((k2 >: State s) : xs) a -> s -> Eff xs (a, s)
runStateEff
{-# INLINE runStateDef #-}

-- | 'evalStateEff' specialised for the 'MonadState' instance.
evalStateDef :: Eff (StateDef s ': xs) a -> s -> Eff xs a
evalStateDef :: Eff (StateDef s : xs) a -> s -> Eff xs a
evalStateDef = Eff (StateDef s : xs) a -> s -> Eff xs a
forall k1 (k2 :: k1) s (xs :: [Assoc k1 (* -> *)]) a.
Eff ((k2 >: State s) : xs) a -> s -> Eff xs a
evalStateEff
{-# INLINE evalStateDef #-}

-- | 'execStateEff' specialised for the 'MonadState' instance.
execStateDef :: Eff (StateDef s ': xs) a -> s -> Eff xs s
execStateDef :: Eff (StateDef s : xs) a -> s -> Eff xs s
execStateDef = Eff (StateDef s : xs) a -> s -> Eff xs s
forall k1 (k2 :: k1) s (xs :: [Assoc k1 (* -> *)]) a.
Eff ((k2 >: State s) : xs) a -> s -> Eff xs s
execStateEff
{-# INLINE execStateDef #-}

-- | mtl-compatible writer
type WriterDef w = "Writer" >: WriterEff w

-- | 'runWriterDef' specialised for the 'MonadWriter' instance.
runWriterDef :: Monoid w => Eff (WriterDef w ': xs) a -> Eff xs (a, w)
runWriterDef :: Eff (WriterDef w : xs) a -> Eff xs (a, w)
runWriterDef = Eff (WriterDef w : xs) a -> Eff xs (a, w)
forall k1 (k2 :: k1) w (xs :: [Assoc k1 (* -> *)]) a.
Monoid w =>
Eff ((k2 >: WriterEff w) : xs) a -> Eff xs (a, w)
runWriterEff
{-# INLINE runWriterDef #-}

-- | 'execWriterDef' specialised for the 'MonadWriter' instance.
execWriterDef :: Monoid w => Eff (WriterDef w ': xs) a -> Eff xs w
execWriterDef :: Eff (WriterDef w : xs) a -> Eff xs w
execWriterDef = Eff (WriterDef w : xs) a -> Eff xs w
forall k1 (k2 :: k1) w (xs :: [Assoc k1 (* -> *)]) a.
Monoid w =>
Eff ((k2 >: WriterEff w) : xs) a -> Eff xs w
execWriterEff
{-# INLINE execWriterDef #-}

-- | Same as @'EitherDef' ()@
type MaybeDef = "Either" >: EitherEff ()

-- | Similar to 'runMaybeT', but on 'Eff'
runMaybeDef :: Eff (MaybeDef ': xs) a -> Eff xs (Maybe a)
runMaybeDef :: Eff (MaybeDef : xs) a -> Eff xs (Maybe a)
runMaybeDef = Eff (MaybeDef : xs) a -> Eff xs (Maybe a)
forall k1 (k2 :: k1) (xs :: [Assoc k1 (* -> *)]) a.
Eff ((k2 >: MaybeEff) : xs) a -> Eff xs (Maybe a)
runMaybeEff
{-# INLINE runMaybeDef #-}

-- | mtl-compatible either effect
type EitherDef e = "Either" >: EitherEff e

-- | Similar to 'runExceptT', but on 'Eff'
runEitherDef :: Eff (EitherDef e ': xs) a -> Eff xs (Either e a)
runEitherDef :: Eff (EitherDef e : xs) a -> Eff xs (Either e a)
runEitherDef = Eff (EitherDef e : xs) a -> Eff xs (Either e a)
forall k1 (k2 :: k1) e (xs :: [Assoc k1 (* -> *)]) a.
Eff ((k2 >: EitherEff e) : xs) a -> Eff xs (Either e a)
runEitherEff
{-# INLINE runEitherDef #-}

-- | mtl-compatible continuation
type ContDef r m = "Cont" >: ContT r m

-- | 'runContEff' specialised for the 'MonadCont' instance.
runContDef :: Eff (ContDef r (Eff xs) ': xs) a -> (a -> Eff xs r) -> Eff xs r
runContDef :: Eff (ContDef r (Eff xs) : xs) a -> (a -> Eff xs r) -> Eff xs r
runContDef = Eff (ContDef r (Eff xs) : xs) a -> (a -> Eff xs r) -> Eff xs r
forall k1 (k2 :: k1) r (xs :: [Assoc k1 (* -> *)]) a.
Eff ((k2 >: ContT r (Eff xs)) : xs) a
-> (a -> Eff xs r) -> Eff xs r
runContEff
{-# INLINE runContDef #-}