module Ether.TagDispatch
(
TagAttachT
, tagAttach
, TagReplaceT
, tagReplace
, TAG_ATTACH
, TAG_REPLACE
) where
import qualified Control.Monad.Error.Class as Mtl
import qualified Control.Monad.Reader.Class as Mtl
import qualified Control.Monad.State.Class as Mtl
import qualified Control.Monad.Writer.Class as Mtl
import Ether.Except
import Ether.Reader
import Ether.State
import Ether.Writer
import Ether.TaggedTrans
import Control.Monad.Trans.Identity
import Data.Coerce
data TAG_ATTACH t
type TagAttachT t = TaggedTrans (TAG_ATTACH t) IdentityT
tagAttach :: forall tag m a . TagAttachT tag m a -> m a
tagAttach = coerce (runIdentityT @_ @m @a)
instance
( MonadReader tag r m, trans ~ IdentityT
) => Mtl.MonadReader r (TaggedTrans (TAG_ATTACH tag) trans m)
where
ask = ask @tag
local = local @tag
reader = reader @tag
instance
( MonadState tag s m, trans ~ IdentityT
) => Mtl.MonadState s (TaggedTrans (TAG_ATTACH tag) trans m)
where
get = get @tag
put = put @tag
state = state @tag
instance
( MonadExcept tag e m, trans ~ IdentityT
) => Mtl.MonadError e (TaggedTrans (TAG_ATTACH tag) trans m)
where
throwError = throw @tag
catchError = catch @tag
instance
( MonadWriter tag w m, trans ~ IdentityT
) => Mtl.MonadWriter w (TaggedTrans (TAG_ATTACH tag) trans m)
where
writer = writer @tag
tell = tell @tag
listen = listen @tag
pass = pass @tag
data TAG_REPLACE tOld tNew
type TagReplaceT tOld tNew = TaggedTrans (TAG_REPLACE tOld tNew) IdentityT
tagReplace :: forall tOld tNew m a . TagReplaceT tOld tNew m a -> m a
tagReplace = coerce (runIdentityT @_ @m @a)
instance
( MonadReader tNew r m, trans ~ IdentityT
) => MonadReader tOld r (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
where
ask = ask @tNew
local = local @tNew
reader = reader @tNew
instance
( MonadState tNew s m, trans ~ IdentityT
) => MonadState tOld s (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
where
get = get @tNew
put = put @tNew
state = state @tNew
instance
( MonadExcept tNew e m, trans ~ IdentityT
) => MonadExcept tOld e (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
where
throw = throw @tNew
catch = catch @tNew
instance
( MonadWriter tNew w m, trans ~ IdentityT
) => MonadWriter tOld w (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
where
writer = writer @tNew
tell = tell @tNew
listen = listen @tNew
pass = pass @tNew