{-# 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 #-}