@@ -3,6 +3,7 @@
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE UndecidableInstances #-}
55{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
67{-# LANGUAGE GeneralizedNewtypeDeriving #-}
78
89{- |
@@ -33,6 +34,7 @@ import Control.Monad (MonadPlus)
3334import Control.Monad.Fix (MonadFix)
3435import Control.Monad.IO.Class (MonadIO)
3536import GHC.Generics (Generic)
37+import Data.Coerce (coerce)
3638
3739import Control.Monad.Ether.Reader.Class
3840import Control.Monad.Ether.State.Class
@@ -44,6 +46,9 @@ import qualified Control.Monad.State as Class
4446import qualified Control.Monad.Except as Class
4547import qualified Control.Monad.Writer as Class
4648
49+import qualified Control.Monad.Base as MB
50+import qualified Control.Monad.Trans.Control as MC
51+
4752-- | Wrap a monad to attach a tag to it.
4853newtype WrappedEther tag m a = WrapEther { unwrapEther :: m a }
4954 deriving ( Generic
@@ -52,15 +57,23 @@ newtype WrappedEther tag m a = WrapEther { unwrapEther :: m a }
5257
5358-- | Annotate a polymorphic monadic computation with a tag.
5459ethered :: proxy tag -> WrappedEther tag m a -> m a
55−ethered _proxy = unwrapEther
60+ethered _proxy = coerce
61+
62+instance MB.MonadBase b m => MB.MonadBase b (WrappedEther tag m) where
63+ liftBase a = WrapEther (MB.liftBase a)
64+
65+instance MC.MonadBaseControl b m => MC.MonadBaseControl b (WrappedEther tag m) where
66+ type StM (WrappedEther tag m) a = MC.StM m a
67+ liftBaseWith a = WrapEther (MC.liftBaseWith (a . coerce))
68+ restoreM a = WrapEther (MC.restoreM a)
5669
5770instance MonadReader tag r m => Class.MonadReader r (WrappedEther tag m) where
5871 ask = WrapEther $ ask (Proxy :: Proxy tag)
59− local f = WrapEther . local (Proxy :: Proxy tag) f . unwrapEther
72+ local f = WrapEther . local (Proxy :: Proxy tag) f . coerce
6073
6174instance MonadReader tag r m => MonadReader tag r (WrappedEther tag' m) where
6275 ask t = WrapEther $ ask t
63− local t f = WrapEther . local t f . unwrapEther
76+ local t f = WrapEther . local t f . coerce
6477
6578instance MonadState tag s m => Class.MonadState s (WrappedEther tag m) where
6679 get = WrapEther $ get (Proxy :: Proxy tag)
@@ -72,18 +85,18 @@ instance MonadState tag s m => MonadState tag s (WrappedEther tag' m) where
7285
7386instance MonadExcept tag e m => Class.MonadError e (WrappedEther tag m) where
7487 throwError = WrapEther . throw (Proxy :: Proxy tag)
75− catchError m h = WrapEther $ catch (Proxy :: Proxy tag) (unwrapEther m) (unwrapEther . h)
88+ catchError m h = WrapEther $ catch (Proxy :: Proxy tag) (coerce m) (coerce . h)
7689
7790instance MonadExcept tag e m => MonadExcept tag e (WrappedEther tag' m) where
7891 throw t = WrapEther . throw t
79− catch t m h = WrapEther $ catch t (unwrapEther m) (unwrapEther . h)
92+ catch t m h = WrapEther $ catch t (coerce m) (coerce . h)
8093
8194instance MonadWriter tag w m => Class.MonadWriter w (WrappedEther tag m) where
8295 tell = WrapEther . tell (Proxy :: Proxy tag)
83− listen = WrapEther . listen (Proxy :: Proxy tag) . unwrapEther
84− pass = WrapEther . pass (Proxy :: Proxy tag) . unwrapEther
96+ listen = WrapEther . listen (Proxy :: Proxy tag) . coerce
97+ pass = WrapEther . pass (Proxy :: Proxy tag) . coerce
8598
8699instance MonadWriter tag w m => MonadWriter tag w (WrappedEther tag' m) where
87100 tell t = WrapEther . tell t
88− listen t = WrapEther . listen t . unwrapEther
89− pass t = WrapEther . pass t . unwrapEther
101+ listen t = WrapEther . listen t . coerce
102+ pass t = WrapEther . pass t . coerce