{-# 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
--
-- Default monad runners and 'MonadIO', 'MonadReader', 'MonadWriter',
-- 'MonadState', 'MonadError' instances
-----------------------------------------------------------------------------
module Data.Extensible.Effect.Default (
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 = liftEff (Proxy :: Proxy "IO") . liftIO
#if MIN_VERSION_resourcet(1,2,0)
instance (MonadResource m, Lookup xs "IO" m) => MonadResource (Eff xs) where
liftResourceT = liftEff (Proxy :: Proxy "IO") . liftResourceT
#endif
instance (MonadThrow m, Lookup xs "IO" m) => MonadThrow (Eff xs) where
throwM = liftEff (Proxy :: Proxy "IO") . throwM
instance (MonadCatch m, Lookup xs "IO" m) => MonadCatch (Eff xs) where
catch m0 h = go m0 where
go m = case debone m of
Return a -> return a
Instruction i t :>>= k -> case compareMembership (association :: Membership xs ("IO" ':> m)) i of
Left _ -> boned $ Instruction i t :>>= go . k
Right Refl -> boned $ Instruction i (try t) :>>= go . either h k
pReader :: Proxy "Reader"
pReader = Proxy
instance Lookup xs "Reader" ((:~:) r) => MonadReader r (Eff xs) where
ask = askEff pReader
local = localEff pReader
reader = asksEff pReader
pState :: Proxy "State"
pState = Proxy
instance Lookup xs "State" (State s) => MonadState s (Eff xs) where
get = getEff pState
put = putEff pState
state = stateEff pState
pWriter :: Proxy "Writer"
pWriter = Proxy
instance (Monoid w, Lookup xs "Writer" ((,) w)) => MonadWriter w (Eff xs) where
writer = writerEff pWriter
tell = tellEff pWriter
listen = listenEff pWriter
pass = passEff pWriter
pEither :: Proxy "Either"
pEither = Proxy
instance (Lookup xs "Either" (Const e)) => MonadError e (Eff xs) where
throwError = throwEff pEither
catchError = catchEff pEither
-- | A bit dubious
instance (Monoid e, Lookup xs "Either" (Const e)) => Alternative (Eff xs) where
empty = throwError mempty
p <|> q = catchError p (const q)
instance (Monoid e, Lookup xs "Either" (Const e)) => MonadPlus (Eff xs) where
mzero = empty
mplus = (<|>)
pCont :: Proxy "Cont"
pCont = Proxy
instance MonadCont (Eff ((ContDef r (Eff xs)) ': xs)) where
callCC = callCCEff 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 = 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 = runStateEff
{-# INLINE runStateDef #-}
-- | 'evalStateEff' specialised for the 'MonadState' instance.
evalStateDef :: Eff (StateDef s ': xs) a -> s -> Eff xs a
evalStateDef = evalStateEff
{-# INLINE evalStateDef #-}
-- | 'execStateEff' specialised for the 'MonadState' instance.
execStateDef :: Eff (StateDef s ': xs) a -> s -> Eff xs s
execStateDef = 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 = runWriterEff
{-# INLINE runWriterDef #-}
-- | 'execWriterDef' specialised for the 'MonadWriter' instance.
execWriterDef :: Monoid w => Eff (WriterDef w ': xs) a -> Eff xs w
execWriterDef = 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 = 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 = 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 = runContEff
{-# INLINE runContDef #-}