{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE BlockArguments #-}
-- | A two-screen slice of @transformers@: the three monad transformers the
-- plugin uses (@ReaderT@, strict @WriterT@, @MaybeT@), inlined so the library
-- depends only on @base@ and @ghc@.  They are used /only/ as @DerivingVia@
-- targets (the synthesis monad in "Stock.Derive", the first-success 'Monoid' in
-- "Stock.Internal"), so the representations match @transformers@ exactly — that
-- is what lets the @via@ coercions go through — and none of the combinators
-- (@lift@, @ask@, @tell@, @runReaderT@, …) are needed beyond the constructors.
module Stock.Trans
  ( ReaderT(..)
  , WriterT(..)
  , MaybeT(..)
  ) where

import Control.Applicative (Alternative(..))
import Control.Monad (ap)
-- liftA2 comes from Prelude (base >= 4.18 / GHC >= 9.6)

-- | @r -> m a@, exactly as in @Control.Monad.Trans.Reader@.
newtype ReaderT r m a = ReaderT { forall {k} r (m :: k -> *) (a :: k). ReaderT r m a -> r -> m a
runReaderT :: r -> m a }

-- | @m (a, w)@ — the /strict/ writer (value first), as in
-- @Control.Monad.Trans.Writer.Strict@.
newtype WriterT w m a = WriterT { forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT :: m (a, w) }

-- | @m (Maybe a)@, exactly as in @Control.Monad.Trans.Maybe@.
newtype MaybeT m a = MaybeT { forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT :: m (Maybe a) }

instance Functor m => Functor (ReaderT r m) where
  fmap :: (a -> b) -> ReaderT r m a -> ReaderT r m b
  fmap :: forall a b. (a -> b) -> ReaderT r m a -> ReaderT r m b
fmap a -> b
f (ReaderT r -> m a
g) = (r -> m b) -> ReaderT r m b
forall {k} r (m :: k -> *) (a :: k). (r -> m a) -> ReaderT r m a
ReaderT ((a -> b) -> m a -> m b
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (m a -> m b) -> (r -> m a) -> r -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> m a
g)

instance Applicative m => Applicative (ReaderT r m) where
  pure :: a -> ReaderT r m a
  pure :: forall a. a -> ReaderT r m a
pure = (r -> m a) -> ReaderT r m a
forall {k} r (m :: k -> *) (a :: k). (r -> m a) -> ReaderT r m a
ReaderT ((r -> m a) -> ReaderT r m a)
-> (a -> r -> m a) -> a -> ReaderT r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> r -> m a
forall a b. a -> b -> a
const (m a -> r -> m a) -> (a -> m a) -> a -> r -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (<*>) :: ReaderT r m (a -> b) -> ReaderT r m a -> ReaderT r m b
  ReaderT r -> m (a -> b)
f <*> :: forall a b. ReaderT r m (a -> b) -> ReaderT r m a -> ReaderT r m b
<*> ReaderT r -> m a
x = (r -> m b) -> ReaderT r m b
forall {k} r (m :: k -> *) (a :: k). (r -> m a) -> ReaderT r m a
ReaderT \r
r -> r -> m (a -> b)
f r
r m (a -> b) -> m a -> m b
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> r -> m a
x r
r

instance Monad m => Monad (ReaderT r m) where
  (>>=) :: ReaderT r m a -> (a -> ReaderT r m b) -> ReaderT r m b
  ReaderT r -> m a
x >>= :: forall a b. ReaderT r m a -> (a -> ReaderT r m b) -> ReaderT r m b
>>= a -> ReaderT r m b
k = (r -> m b) -> ReaderT r m b
forall {k} r (m :: k -> *) (a :: k). (r -> m a) -> ReaderT r m a
ReaderT \r
r -> r -> m a
x r
r m a -> (a -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> ReaderT r m b -> r -> m b
forall {k} r (m :: k -> *) (a :: k). ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT r m b
k a
a) r
r

instance Functor m => Functor (WriterT w m) where
  fmap :: (a -> b) -> WriterT w m a -> WriterT w m b
  fmap :: forall a b. (a -> b) -> WriterT w m a -> WriterT w m b
fmap a -> b
f (WriterT m (a, w)
m) = m (b, w) -> WriterT w m b
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (((a, w) -> (b, w)) -> m (a, w) -> m (b, w)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
a, w
w) -> (a -> b
f a
a, w
w)) m (a, w)
m)

instance (Monoid w, Applicative m) => Applicative (WriterT w m) where
  pure :: a -> WriterT w m a
  pure :: forall a. a -> WriterT w m a
pure a
a = m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT ((a, w) -> m (a, w)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, w
forall a. Monoid a => a
mempty))
  (<*>) :: WriterT w m (a -> b) -> WriterT w m a -> WriterT w m b
  WriterT m (a -> b, w)
mf <*> :: forall a b. WriterT w m (a -> b) -> WriterT w m a -> WriterT w m b
<*> WriterT m (a, w)
mx = m (b, w) -> WriterT w m b
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (((a -> b, w) -> (a, w) -> (b, w))
-> m (a -> b, w) -> m (a, w) -> m (b, w)
forall a b c. (a -> b -> c) -> m a -> m b -> m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (a -> b, w) -> (a, w) -> (b, w)
forall {b} {t} {a}. Semigroup b => (t -> a, b) -> (t, b) -> (a, b)
k m (a -> b, w)
mf m (a, w)
mx)
    where k :: (t -> a, b) -> (t, b) -> (a, b)
k (t -> a
f, b
w) (t
x, b
w') = (t -> a
f t
x, b
w b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
w')

instance (Monoid w, Monad m) => Monad (WriterT w m) where
  (>>=) :: WriterT w m a -> (a -> WriterT w m b) -> WriterT w m b
  WriterT m (a, w)
m >>= :: forall a b. WriterT w m a -> (a -> WriterT w m b) -> WriterT w m b
>>= a -> WriterT w m b
k = m (b, w) -> WriterT w m b
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT do
    (a
a, w
w)  <- m (a, w)
m
    (b
b, w
w') <- WriterT w m b -> m (b, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (a -> WriterT w m b
k a
a)
    (b, w) -> m (b, w)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
b, w
w w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w')

instance Functor m => Functor (MaybeT m) where
  fmap :: (a -> b) -> MaybeT m a -> MaybeT m b
  fmap :: forall a b. (a -> b) -> MaybeT m a -> MaybeT m b
fmap a -> b
f (MaybeT m (Maybe a)
m) = m (Maybe b) -> MaybeT m b
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ((Maybe a -> Maybe b) -> m (Maybe a) -> m (Maybe b)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Maybe a -> Maybe b
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) m (Maybe a)
m)

instance Monad m => Applicative (MaybeT m) where
  pure :: a -> MaybeT m a
  pure :: forall a. a -> MaybeT m a
pure = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe a) -> MaybeT m a)
-> (a -> m (Maybe a)) -> a -> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just
  (<*>) :: MaybeT m (a -> b) -> MaybeT m a -> MaybeT m b
  <*> :: forall a b. MaybeT m (a -> b) -> MaybeT m a -> MaybeT m b
(<*>) = MaybeT m (a -> b) -> MaybeT m a -> MaybeT m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad m => Monad (MaybeT m) where
  (>>=) :: MaybeT m a -> (a -> MaybeT m b) -> MaybeT m b
  MaybeT m (Maybe a)
m >>= :: forall a b. MaybeT m a -> (a -> MaybeT m b) -> MaybeT m b
>>= a -> MaybeT m b
k = m (Maybe b) -> MaybeT m b
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT do
    Maybe a
ma <- m (Maybe a)
m
    case Maybe a
ma of
      Maybe a
Nothing -> Maybe b -> m (Maybe b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing
      Just a
a  -> MaybeT m b -> m (Maybe b)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (a -> MaybeT m b
k a
a)

instance Monad m => Alternative (MaybeT m) where
  empty :: MaybeT m a
  empty :: forall a. MaybeT m a
empty = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)
  (<|>) :: MaybeT m a -> MaybeT m a -> MaybeT m a
  MaybeT m (Maybe a)
a <|> :: forall a. MaybeT m a -> MaybeT m a -> MaybeT m a
<|> MaybeT m (Maybe a)
b = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT do
    Maybe a
ma <- m (Maybe a)
a
    case Maybe a
ma of
      Maybe a
Nothing -> m (Maybe a)
b
      Just a
_  -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
ma