@@ -3,6 +3,7 @@
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE UndecidableInstances #-}
4{-# LANGUAGE UndecidableInstances #-}
5{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -33,6 +34,7 @@ import Control.Monad (MonadPlus)
33import Control.Monad.Fix (MonadFix)
34import Control.Monad.Fix (MonadFix)
34import Control.Monad.IO.Class (MonadIO)
35import Control.Monad.IO.Class (MonadIO)
35import GHC.Generics (Generic)
36import GHC.Generics (Generic)
37+import Data.Coerce (coerce)
37import Control.Monad.Ether.Reader.Class
39import Control.Monad.Ether.Reader.Class
38import Control.Monad.Ether.State.Class
40import Control.Monad.Ether.State.Class
@@ -44,6 +46,9 @@ import qualified Control.Monad.State as Class
44import qualified Control.Monad.Except as Class
46import qualified Control.Monad.Except as Class
45import qualified Control.Monad.Writer as Class
47import qualified Control.Monad.Writer as Class
49+import qualified Control.Monad.Base as MB
50+import qualified Control.Monad.Trans.Control as MC
47-- | Wrap a monad to attach a tag to it.
52-- | Wrap a monad to attach a tag to it.
48newtype WrappedEther tag m a = WrapEther { unwrapEther :: m a }
53newtype WrappedEther tag m a = WrapEther { unwrapEther :: m a }
49 deriving ( Generic
54 deriving ( Generic
@@ -52,15 +57,23 @@ newtype WrappedEther tag m a = WrapEther { unwrapEther :: m a }
53-- | Annotate a polymorphic monadic computation with a tag.
58-- | Annotate a polymorphic monadic computation with a tag.
54ethered :: proxy tag -> WrappedEther tag m a -> m a
59ethered :: proxy tag -> WrappedEther tag m a -> m a
55−ethered _proxy = unwrapEther
60+ethered _proxy = coerce
62+instance MB.MonadBase b m => MB.MonadBase b (WrappedEther tag m) where
63+ liftBase a = WrapEther (MB.liftBase a)
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)
57instance MonadReader tag r m => Class.MonadReader r (WrappedEther tag m) where
70instance MonadReader tag r m => Class.MonadReader r (WrappedEther tag m) where
58 ask = WrapEther $ ask (Proxy :: Proxy tag)
71 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
61instance MonadReader tag r m => MonadReader tag r (WrappedEther tag' m) where
74instance MonadReader tag r m => MonadReader tag r (WrappedEther tag' m) where
62 ask t = WrapEther $ ask t
75 ask t = WrapEther $ ask t
63− local t f = WrapEther . local t f . unwrapEther
76+ local t f = WrapEther . local t f . coerce
65instance MonadState tag s m => Class.MonadState s (WrappedEther tag m) where
78instance MonadState tag s m => Class.MonadState s (WrappedEther tag m) where
66 get = WrapEther $ get (Proxy :: Proxy tag)
79 get = WrapEther $ get (Proxy :: Proxy tag)
@@ -72,18 +85,18 @@ instance MonadState tag s m => MonadState tag s (WrappedEther tag' m) where
73instance MonadExcept tag e m => Class.MonadError e (WrappedEther tag m) where
86instance MonadExcept tag e m => Class.MonadError e (WrappedEther tag m) where
74 throwError = WrapEther . throw (Proxy :: Proxy tag)
87 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)
77instance MonadExcept tag e m => MonadExcept tag e (WrappedEther tag' m) where
90instance MonadExcept tag e m => MonadExcept tag e (WrappedEther tag' m) where
78 throw t = WrapEther . throw t
91 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)
81instance MonadWriter tag w m => Class.MonadWriter w (WrappedEther tag m) where
94instance MonadWriter tag w m => Class.MonadWriter w (WrappedEther tag m) where
82 tell = WrapEther . tell (Proxy :: Proxy tag)
95 tell = WrapEther . tell (Proxy :: Proxy tag)
83− listen = WrapEther . listen (Proxy :: Proxy tag) . unwrapEther
96+ listen = WrapEther . listen (Proxy :: Proxy tag) . coerce
84− pass = WrapEther . pass (Proxy :: Proxy tag) . unwrapEther
97+ pass = WrapEther . pass (Proxy :: Proxy tag) . coerce
86instance MonadWriter tag w m => MonadWriter tag w (WrappedEther tag' m) where
99instance MonadWriter tag w m => MonadWriter tag w (WrappedEther tag' m) where
87 tell t = WrapEther . tell t
100 tell t = WrapEther . tell t
88− listen t = WrapEther . listen t . unwrapEther
101+ listen t = WrapEther . listen t . coerce
89− pass t = WrapEther . pass t . unwrapEther
102+ pass t = WrapEther . pass t . coerce