{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-dodgy-imports #-}

-- |
-- Module      :  Control.Monad.Trans.Identity.Tagged
-- Copyright   :  © 2016–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- The library provides a monad transformer that works just like
-- 'IdentityT', but can be tagged at the type level. This allows us to work
-- with monad stacks as usual, except we can make two identical monad stacks
-- to have different types. The main application for this is, of course, the
-- ability to have different instances for otherwise identical stacks
-- without having to do @newtype@ wrapping.
module Control.Monad.Trans.Identity.Tagged
  ( -- * The tagged identity monad transformer
    TaggedT (..),
    mapTaggedT,

    -- * Lifting other operations
    liftCallCC,
    liftCatch,
  )
where

import Control.Applicative
import Control.Monad (MonadPlus (..))
import Control.Monad.Cont.Class hiding (liftCallCC)
import Control.Monad.Error.Class
import Control.Monad.Fail qualified as Fail
import Control.Monad.Fix (MonadFix (..))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.RWS.Class
import Control.Monad.Signatures
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.Zip (MonadZip (..))
import Data.Functor.Classes

-- | Identity monad transformer with a type-level tag.
newtype TaggedT tag f a = TaggedT {forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
TaggedT tag f a -> f a
runTaggedT :: f a}

----------------------------------------------------------------------------
-- Standard instances

instance (Eq1 f) => Eq1 (TaggedT tag f) where
  liftEq :: forall a b.
(a -> b -> Bool) -> TaggedT tag f a -> TaggedT tag f b -> Bool
liftEq a -> b -> Bool
eq (TaggedT f a
x) (TaggedT f b
y) = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq f a
x f b
y
  {-# INLINE liftEq #-}

instance (Ord1 f) => Ord1 (TaggedT tag f) where
  liftCompare :: forall a b.
(a -> b -> Ordering)
-> TaggedT tag f a -> TaggedT tag f b -> Ordering
liftCompare a -> b -> Ordering
comp (TaggedT f a
x) (TaggedT f b
y) = forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
comp f a
x f b
y
  {-# INLINE liftCompare #-}

instance (Read1 f) => Read1 (TaggedT tag f) where
  liftReadsPrec :: forall a.
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (TaggedT tag f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl =
    forall a. (String -> ReadS a) -> Int -> ReadS a
readsData forall a b. (a -> b) -> a -> b
$
      forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl) String
"TaggedT" forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT

instance (Show1 f) => Show1 (TaggedT tag f) where
  liftShowsPrec :: forall a.
(Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> TaggedT tag f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
d (TaggedT f a
m) =
    forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl) String
"TaggedT" Int
d f a
m

instance (Eq1 f, Eq a) => Eq (TaggedT tag f a) where
  == :: TaggedT tag f a -> TaggedT tag f a -> Bool
(==) = forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1

instance (Ord1 f, Ord a) => Ord (TaggedT tag f a) where
  compare :: TaggedT tag f a -> TaggedT tag f a -> Ordering
compare = forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

instance (Read1 f, Read a) => Read (TaggedT tag f a) where
  readsPrec :: Int -> ReadS (TaggedT tag f a)
readsPrec = forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1

instance (Show1 f, Show a) => Show (TaggedT tag f a) where
  showsPrec :: Int -> TaggedT tag f a -> ShowS
showsPrec = forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1

instance (Functor m) => Functor (TaggedT tag m) where
  fmap :: forall a b. (a -> b) -> TaggedT tag m a -> TaggedT tag m b
fmap a -> b
f = forall {k} {k} {k} (m :: k -> *) (a :: k) (n :: k -> *) (b :: k)
       (tag :: k).
(m a -> n b) -> TaggedT tag m a -> TaggedT tag n b
mapTaggedT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)
  {-# INLINE fmap #-}

instance (Foldable f) => Foldable (TaggedT tag f) where
  foldMap :: forall m a. Monoid m => (a -> m) -> TaggedT tag f a -> m
foldMap a -> m
f (TaggedT f a
a) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f f a
a
  {-# INLINE foldMap #-}

instance (Traversable f) => Traversable (TaggedT tag f) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TaggedT tag f a -> f (TaggedT tag f b)
traverse a -> f b
f (TaggedT f a
a) = forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f f a
a
  {-# INLINE traverse #-}

instance (Applicative m) => Applicative (TaggedT tag m) where
  pure :: forall a. a -> TaggedT tag m a
pure a
x = forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
  {-# INLINE pure #-}
  <*> :: forall a b.
TaggedT tag m (a -> b) -> TaggedT tag m a -> TaggedT tag m b
(<*>) = forall {k} {k} {k} {k} (m :: k -> *) (a :: k) (n :: k -> *)
       (b :: k) (p :: k -> *) (c :: k) (tag :: k).
(m a -> n b -> p c)
-> TaggedT tag m a -> TaggedT tag n b -> TaggedT tag p c
lift2TaggedT forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
  {-# INLINE (<*>) #-}

instance (Alternative m) => Alternative (TaggedT tag m) where
  empty :: forall a. TaggedT tag m a
empty = forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT forall (f :: * -> *) a. Alternative f => f a
empty
  {-# INLINE empty #-}
  <|> :: forall a. TaggedT tag m a -> TaggedT tag m a -> TaggedT tag m a
(<|>) = forall {k} {k} {k} {k} (m :: k -> *) (a :: k) (n :: k -> *)
       (b :: k) (p :: k -> *) (c :: k) (tag :: k).
(m a -> n b -> p c)
-> TaggedT tag m a -> TaggedT tag n b -> TaggedT tag p c
lift2TaggedT forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
  {-# INLINE (<|>) #-}

instance (Monad m) => Monad (TaggedT tag m) where
  TaggedT tag m a
m >>= :: forall a b.
TaggedT tag m a -> (a -> TaggedT tag m b) -> TaggedT tag m b
>>= a -> TaggedT tag m b
k = forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT forall a b. (a -> b) -> a -> b
$ forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
TaggedT tag f a -> f a
runTaggedT forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TaggedT tag m b
k forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
TaggedT tag f a -> f a
runTaggedT TaggedT tag m a
m
  {-# INLINE (>>=) #-}

instance (Fail.MonadFail m) => Fail.MonadFail (TaggedT tag m) where
  fail :: forall a. String -> TaggedT tag m a
fail String
msg = forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
msg
  {-# INLINE fail #-}

instance (MonadPlus m) => MonadPlus (TaggedT tag m) where
  mzero :: forall a. TaggedT tag m a
mzero = forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT forall (m :: * -> *) a. MonadPlus m => m a
mzero
  {-# INLINE mzero #-}
  mplus :: forall a. TaggedT tag m a -> TaggedT tag m a -> TaggedT tag m a
mplus = forall {k} {k} {k} {k} (m :: k -> *) (a :: k) (n :: k -> *)
       (b :: k) (p :: k -> *) (c :: k) (tag :: k).
(m a -> n b -> p c)
-> TaggedT tag m a -> TaggedT tag n b -> TaggedT tag p c
lift2TaggedT forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
  {-# INLINE mplus #-}

instance (MonadFix m) => MonadFix (TaggedT tag m) where
  mfix :: forall a. (a -> TaggedT tag m a) -> TaggedT tag m a
mfix a -> TaggedT tag m a
f = forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT (forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
TaggedT tag f a -> f a
runTaggedT forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TaggedT tag m a
f))
  {-# INLINE mfix #-}

instance (MonadIO m) => MonadIO (TaggedT tag m) where
  liftIO :: forall a. IO a -> TaggedT tag m a
liftIO = forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
  {-# INLINE liftIO #-}

instance (MonadZip m) => MonadZip (TaggedT tag m) where
  mzipWith :: forall a b c.
(a -> b -> c)
-> TaggedT tag m a -> TaggedT tag m b -> TaggedT tag m c
mzipWith a -> b -> c
f = forall {k} {k} {k} {k} (m :: k -> *) (a :: k) (n :: k -> *)
       (b :: k) (p :: k -> *) (c :: k) (tag :: k).
(m a -> n b -> p c)
-> TaggedT tag m a -> TaggedT tag n b -> TaggedT tag p c
lift2TaggedT (forall (m :: * -> *) a b c.
MonadZip m =>
(a -> b -> c) -> m a -> m b -> m c
mzipWith a -> b -> c
f)
  {-# INLINE mzipWith #-}

instance MonadTrans (TaggedT tag) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> TaggedT tag m a
lift = forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT
  {-# INLINE lift #-}

-- | Lift a unary operation to the new monad.
mapTaggedT :: (m a -> n b) -> TaggedT tag m a -> TaggedT tag n b
mapTaggedT :: forall {k} {k} {k} (m :: k -> *) (a :: k) (n :: k -> *) (b :: k)
       (tag :: k).
(m a -> n b) -> TaggedT tag m a -> TaggedT tag n b
mapTaggedT m a -> n b
f = forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> n b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
TaggedT tag f a -> f a
runTaggedT
{-# INLINE mapTaggedT #-}

-- | Lift a binary operation to the new monad.
lift2TaggedT :: (m a -> n b -> p c) -> TaggedT tag m a -> TaggedT tag n b -> TaggedT tag p c
lift2TaggedT :: forall {k} {k} {k} {k} (m :: k -> *) (a :: k) (n :: k -> *)
       (b :: k) (p :: k -> *) (c :: k) (tag :: k).
(m a -> n b -> p c)
-> TaggedT tag m a -> TaggedT tag n b -> TaggedT tag p c
lift2TaggedT m a -> n b -> p c
f TaggedT tag m a
a TaggedT tag n b
b = forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT (m a -> n b -> p c
f (forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
TaggedT tag f a -> f a
runTaggedT TaggedT tag m a
a) (forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
TaggedT tag f a -> f a
runTaggedT TaggedT tag n b
b))
{-# INLINE lift2TaggedT #-}

-- | Lift a @callCC@ operation to the new monad.
liftCallCC :: CallCC m a b -> CallCC (TaggedT tag m) a b
liftCallCC :: forall {k} (m :: * -> *) a b (tag :: k).
CallCC m a b -> CallCC (TaggedT tag m) a b
liftCallCC CallCC m a b
callCC' (a -> TaggedT tag m b) -> TaggedT tag m a
f =
  forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT forall a b. (a -> b) -> a -> b
$ CallCC m a b
callCC' forall a b. (a -> b) -> a -> b
$ \a -> m b
c -> forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
TaggedT tag f a -> f a
runTaggedT ((a -> TaggedT tag m b) -> TaggedT tag m a
f (forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
c))
{-# INLINE liftCallCC #-}

-- | Lift a @catchE@ operation to the new monad.
liftCatch :: Catch e m a -> Catch e (TaggedT tag m) a
liftCatch :: forall {k} {k} e (m :: k -> *) (a :: k) (tag :: k).
Catch e m a -> Catch e (TaggedT tag m) a
liftCatch Catch e m a
f TaggedT tag m a
m e -> TaggedT tag m a
h = forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
f a -> TaggedT tag f a
TaggedT forall a b. (a -> b) -> a -> b
$ Catch e m a
f (forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
TaggedT tag f a -> f a
runTaggedT TaggedT tag m a
m) (forall {k} {k} (tag :: k) (f :: k -> *) (a :: k).
TaggedT tag f a -> f a
runTaggedT forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> TaggedT tag m a
h)
{-# INLINE liftCatch #-}

----------------------------------------------------------------------------
-- MTL instances

instance (MonadCont m) => MonadCont (TaggedT tag m) where
  callCC :: forall a b.
((a -> TaggedT tag m b) -> TaggedT tag m a) -> TaggedT tag m a
callCC = forall {k} (m :: * -> *) a b (tag :: k).
CallCC m a b -> CallCC (TaggedT tag m) a b
liftCallCC forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC

instance (MonadError e m) => MonadError e (TaggedT tag m) where
  throwError :: forall a. e -> TaggedT tag m a
throwError = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: forall a.
TaggedT tag m a -> (e -> TaggedT tag m a) -> TaggedT tag m a
catchError = forall {k} {k} e (m :: k -> *) (a :: k) (tag :: k).
Catch e m a -> Catch e (TaggedT tag m) a
liftCatch forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError

instance (MonadRWS r w s m) => MonadRWS r w s (TaggedT tag m)

instance (MonadReader r m) => MonadReader r (TaggedT tag m) where
  ask :: TaggedT tag m r
ask = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: forall a. (r -> r) -> TaggedT tag m a -> TaggedT tag m a
local = forall {k} {k} {k} (m :: k -> *) (a :: k) (n :: k -> *) (b :: k)
       (tag :: k).
(m a -> n b) -> TaggedT tag m a -> TaggedT tag n b
mapTaggedT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
  reader :: forall a. (r -> a) -> TaggedT tag m a
reader = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader

instance (MonadState s m) => MonadState s (TaggedT tag m) where
  get :: TaggedT tag m s
get = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *). MonadState s m => m s
get
  put :: s -> TaggedT tag m ()
put = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => s -> m ()
put
  state :: forall a. (s -> (a, s)) -> TaggedT tag m a
state = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state

instance (MonadWriter w m) => MonadWriter w (TaggedT tag m) where
  writer :: forall a. (a, w) -> TaggedT tag m a
writer = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer
  tell :: w -> TaggedT tag m ()
tell = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  listen :: forall a. TaggedT tag m a -> TaggedT tag m (a, w)
listen = forall {k} {k} {k} (m :: k -> *) (a :: k) (n :: k -> *) (b :: k)
       (tag :: k).
(m a -> n b) -> TaggedT tag m a -> TaggedT tag n b
mapTaggedT forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
  pass :: forall a. TaggedT tag m (a, w -> w) -> TaggedT tag m a
pass = forall {k} {k} {k} (m :: k -> *) (a :: k) (n :: k -> *) (b :: k)
       (tag :: k).
(m a -> n b) -> TaggedT tag m a -> TaggedT tag n b
mapTaggedT forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass