A little talk for Friday afternoon.

Transformers.hs

{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MonoLocalBinds             #-}
{-# LANGUAGE QuantifiedConstraints      #-}
module Transformers where

import Data.Functor.Identity (Identity (..))
import Data.Kind (Type)

main :: IO ()
main = putStrLn "TRANSFORMERS"

-- ──────────▄▄▄▄▄▄▄▄▄──────────
-- ───────▄█████████████▄───────
-- ▐███▌─█████████████████─▐███▌
-- ─████▄─▀███▄─────▄███▀─▄████─
-- ─▐█████▄─▀███▄─▄███▀─▄█████▌─
-- ──██▄▀███▄─▀█████▀─▄███▀▄██──
-- ──▐█▀█▄▀███─▄─▀─▄─███▀▄█▀█▌──
-- ───██▄▀█▄██─██▄██─██▄█▀▄██───
-- ────▀██▄▀██─█████─██▀▄██▀────
-- ───▄──▀████─█████─████▀──▄───
-- ───██────────███────────██───
-- ───██▄────▄█─███─█▄────▄██───
-- ───████─▄███─███─███▄─████───
-- ───████─████─███─████─████───
-- ───████─████─███─████─████───
-- ───████─████▄▄▄▄▄████─████───
-- ───▀███─█████████████─███▀───
-- ─────▀█─███─▄▄▄▄▄─███─█▀─────
-- ────────▀█▌▐█████▌▐█▀────────
-- ───────────███████───────────

-------------------------------------------------------------------------------
-- 1. WHY IS A TRANSFORMER?

something :: IO (Maybe Int)
something = undefined

another :: IO (Maybe String)
another = undefined

program :: IO ()
program = do
  x <- something :: IO (Maybe Int)
  y <- another   :: IO (Maybe String)

  case (x, y) of
    (Just x', Just y') -> do
      print x'
      print y'
    
    (_, _) -> pure ()

-- program' :: MaybeT IO ()
-- program' = do
--   x <- MaybeT something
--   y <- MaybeT another
-- 
--   lift (print x)
--   lift (print y)

-------------------------------------------------------------------------------
-- 2. WHAT IS A TRANSFORMER?

type Transformer = (Type -> Type) -> (Type -> Type)
--                  ^ inner           ^ transformed


class (forall m. Monad m => Monad (t m))

    => MonadTrans (t :: Transformer) where

  lift :: Monad m => m a -> t m a


-- "Transform" a monad into a "more powerful" monad.
-- "Promote" actions from the inner monad.

-------------------------------------------------------------------------------
-- 3. HOW DO I WORK THIS THING?

inject  :: (Monad m, MonadTrans t) => a -> t m a
inject = lift . return

promote :: (MonadTrans t, Monad m) => m a -> t m a
promote = lift

-- demote :: (MonadTrans t, Monad m) => t m a -> m a

newtype IdentityT (m :: Type -> Type) (a :: Type)
  = IdentityT { runIdentityT :: m a }
  deriving newtype (Functor, Applicative, Monad)

instance MonadTrans IdentityT where
  lift = IdentityT

-- demoteIdentityT :: IdentityT m a -> m a
-- demoteIdentityT = _

w :: a -> IdentityT Identity a
w = lift . return

t :: a -> IdentityT (IdentityT Identity)  a
t = lift . lift . return

f :: a -> IdentityT (IdentityT (IdentityT Identity)) a
f = lift . lift . lift . return

-------------------------------------------------------------------------------
-- 4. COMMON TRANSFORMERS

newtype MaybeT (m :: Type -> Type) (a :: Type)
  = MaybeT { runMaybeT :: m (Maybe a) }
  deriving stock Functor

instance Applicative m => Applicative (MaybeT m) where
  pure x = MaybeT (pure (Just x))

  MaybeT f <*> MaybeT x
    = MaybeT ((<*>) <$> f <*> x)

instance Monad m => Monad (MaybeT m) where
  MaybeT x >>= f = MaybeT do
    maybeInner <- x

    case maybeInner of
      Just inner -> runMaybeT (f inner)
      Nothing    -> pure Nothing

instance MonadTrans MaybeT where
  lift = MaybeT . fmap Just

newtype ReaderT (r :: Type) (m :: Type -> Type) (a :: Type)
  = ReaderT { runReaderT :: r -> m a }
  deriving stock Functor

instance Applicative m => Applicative (ReaderT r m) where
  pure x = ReaderT \_ -> pure x
  
  ReaderT f <*> ReaderT x = ReaderT \r -> f r <*> x r

instance Monad m => Monad (ReaderT r m) where
  ReaderT x >>= f = ReaderT \r ->
    x r >>= \a -> runReaderT (f a) r

instance MonadTrans (ReaderT r) where
  lift ma = ReaderT \_ -> ma

ask_ :: Applicative m => ReaderT r m r
ask_ = ReaderT pure

newtype ExceptT (e :: Type) (m :: Type -> Type) (a :: Type)
  = ExceptT { runExceptT :: m (Either e a) }
  deriving stock Functor

instance Applicative m => Applicative (ExceptT e m) where
  pure = ExceptT . pure . Right

  ExceptT f <*> ExceptT x = ExceptT ((<*>) <$> f <*> x)

instance Monad m => Monad (ExceptT e m) where
  ExceptT x >>= f = ExceptT do
    eitherInner <- x

    case eitherInner of
      Right inner -> runExceptT (f inner)
      Left error  -> pure (Left error)

instance MonadTrans (ExceptT e) where
  lift = ExceptT . fmap Right

-------------------------------------------------------------------------------
-- 5. WHAT ABOUT `Something a -> SomethingT m a`

hoistMaybe :: Applicative m => Maybe a -> MaybeT m a
hoistMaybe = \case
  Just x  -> pure x
  Nothing -> MaybeT (pure Nothing)

hoistReader :: Applicative m => (r -> a) -> ReaderT r m a
hoistReader ma = ReaderT (pure . ma)

-------------------------------------------------------------------------------
-- 6. MONAD CLASSES

class Monad m => MonadIO (m :: Type -> Type) where
  liftIO :: IO a -> m a

instance MonadIO IO where
  liftIO = id

instance MonadIO m => MonadIO (ReaderT r m) where
  liftIO = lift . liftIO

instance MonadIO m => MonadIO (ExceptT e m) where
  liftIO = lift . liftIO

class Monad m => MonadReader (r :: Type) (m :: Type -> Type)
    | m -> r where
  ask :: m r

instance Monad m => MonadReader r (ReaderT r m) where
  ask = ask_

class Monad m => MonadError (e :: Type) (m :: Type -> Type) 
    | m -> e where
  throw :: e -> m ()
  catch :: (e -> m a) -> m a -> m a

instance (Monad m, Monad (ExceptT e m)) => MonadError e (ExceptT e m) where
  throw = ExceptT . pure . Left
  catch k (ExceptT xs) = ExceptT do
    inner <- xs

    case inner of
      Left e -> runExceptT (k e)
      Right x -> pure (Right x)

example :: (MonadIO m, MonadReader String m) => m ()
example = do
  text <- ask

  liftIO (print text)

test :: ReaderT String (ExceptT Int IO) ()
test = example

-------------------------------------------------------------------------------
-- 7. `mapFailureTo` AND OTHER FRIGHTENING IDEAS

-- mapFailureTo :: (MonadError e m, MonadError e' m') => m a -> m' a
-- mapFailureTo = _

mapErrorTo :: Monad m => (e -> e') -> ExceptT e m a -> ExceptT e' m a
mapErrorTo f (ExceptT xs) = ExceptT do
  inner <- xs

  case inner of
    Left x -> pure (Left (f x))
    Right x -> pure (Right x)


-- https://www.parsonsmatt.org/2018/04/10/transforming_transformers.html
-- https://github.com/tweag/capability