TagDispatch.hs

{- |

Type-level machinery to manipulate constraints on the monad
transformer stack.

Out of the box it provides the following dispatch strategies:

* 'tagAttach' to use functions defined using untagged monad classes
  as if they were defined using tagged ones.

* 'tagReplace' to use functions defined using one tag
  as if they were defined using another one.

> import Ether
> import Control.Monad.State as Mtl
>
> data Foo
> data Bar
>
> f :: Mtl.MonadState Int m => m String
> f = fmap show Mtl.get
>
> g :: Ether.MonadState Foo Int m => m String
> g = tagAttach @Foo f
>
> h :: Ether.MonadState Bar Int m => m String
> h = tagReplace @Foo @Bar g

-}

module Ether.TagDispatch
  (
  -- * The Tag Attach monad transformer
    TagAttachT
  , tagAttach
  -- * The Tag Replace monad transformer
  , TagReplaceT
  , tagReplace
  -- * Internal labels
  , 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

-- | Encode type-level information for 'tagAttach'.
data TAG_ATTACH t

type TagAttachT t = TaggedTrans (TAG_ATTACH t) IdentityT

-- | Attach a tag to untagged transformers.
tagAttach :: forall tag m a . TagAttachT tag m a -> m a
tagAttach = coerce (runIdentityT @_ @m @a)

instance {-# OVERLAPPING #-}
    ( 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 {-# OVERLAPPING #-}
    ( 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 {-# OVERLAPPING #-}
    ( MonadExcept tag e m, trans ~ IdentityT
    ) => Mtl.MonadError e (TaggedTrans (TAG_ATTACH tag) trans m)
  where
    throwError = throw @tag
    catchError = catch @tag

instance {-# OVERLAPPING #-}
    ( 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

-- | Encode type-level information for 'tagReplace'.
data TAG_REPLACE tOld tNew

type TagReplaceT tOld tNew = TaggedTrans (TAG_REPLACE tOld tNew) IdentityT

-- | Replace a tag with another tag.
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