"Where's lift?" -- Runnable examples from https://stackoverflow.com/a/56726855/2751851

Whereslift.hs

#!/usr/bin/env cabal
{- cabal:
build-depends: base >= 4.12
             , mtl
             , distributive
-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE LambdaCase #-}

-- Examples from my answer to the Stack Overflow question "Do monad
-- transformers, generally speaking, arise out of adjunctions?", available at:
-- https://stackoverflow.com/a/56726855/2751851
module Main where

import Control.Applicative
import Data.Distributive
import Control.Monad.Reader
import Control.Monad.Except

-- ThreeK is a transformer with the feature monad on the outside.
newtype ThreeK g m a = ThreeK { runThreeK :: g (m a) }
    deriving Applicative via WrappedMonad (ThreeK g m)

instance (Functor g, Functor m) => Functor (ThreeK g m) where
    fmap f (ThreeK m) = ThreeK $ fmap (fmap f) m

instance (Monad g, Distributive g, Monad m) => Monad (ThreeK g m) where
    return a = ThreeK $ return (return a)
    m >>= f = ThreeK $ fmap join . join . fmap distribute 
      $ runThreeK $ fmap (runThreeK . f) m

instance (Monad g, Distributive g) => MonadTrans (ThreeK g) where
    lift = ThreeK . return

newtype KReaderT r m a = KReaderT { runKReaderT :: r -> m a }
    deriving (Functor, Applicative, Monad) via ThreeK ((->) r) m
    deriving MonadTrans via ThreeK ((->) r)

-- With an extra Representable constraint, it is in fact possible to write a
-- general MonadReader instance for ThreeK. I'm not including it here because
-- the technicalities might be a bit distracting.
instance Monad m => MonadReader r (KReaderT r m) where
    ask = KReaderT return
    local endo (KReaderT f) = KReaderT $ f . endo


-- ThreeEM is a transformer which composes the feature monad on the inside.
newtype ThreeEM t m a = ThreeEM { runThreeEM :: m (t a) }
    deriving Applicative via WrappedMonad (ThreeEM t m)

instance (Functor t, Functor m) => Functor (ThreeEM t m) where
    fmap f (ThreeEM m) = ThreeEM $ fmap (fmap f) m

-- Note that Traversable is not quite the right constraint. See the "Flipped
-- transformers and the Eilenberg-Moore adjunction" section of the Stack
-- Overflow answer mentioned at the top for discussion.
instance (Monad t, Traversable t, Monad m) => Monad (ThreeEM t m) where
    return a = ThreeEM $ return (return a)
    m >>= f = ThreeEM $ fmap join . join . fmap sequenceA 
      $ runThreeEM $ fmap (runThreeEM . f) m

instance (Monad t, Traversable t) => MonadTrans (ThreeEM t) where
    lift = ThreeEM . fmap return

newtype EMExceptT e m a = EMExceptT { runEMExceptT :: m (Either e a) }
    deriving (Functor, Applicative, Monad) via ThreeEM (Either e) m
    deriving MonadTrans via ThreeEM (Either e)

instance Monad m => MonadError e (EMExceptT e m) where
    throwError err = EMExceptT $ return (Left err)
    catchError m handler = EMExceptT $ runEMExceptT m >>= \case
        Left err -> runEMExceptT (handler err)
        Right a -> return (Right a)


-- "ListT done right" is an example of a different kind of transformer.
-- For a reference implementation, see the list-t package:
-- http://hackage.haskell.org/package/list-t

-- A recursion-schemes style base functor for lists lies at the heart of ListT.
data ListF a b = Nil | Cons a b
    deriving (Eq, Ord, Show, Functor)

-- A list type might be recovered by recursively filling the functorial
-- position in ListF.
newtype DemoList a = DemoList { getDemoList :: ListF a (DemoList a) }

-- To get the transformer, we compose the base monad on the outside of ListF.
newtype ListT m a = ListT { runListT :: m (ListF a (ListT m a)) }
    deriving (Functor, Applicative, Alternative) via WrappedMonad (ListT m)

-- Appending through the monadic layers. Note that mplus only runs the effect
-- first ListF layer; everything eslse can be consumed lazily.
instance Monad m => MonadPlus (ListT m) where
    mzero = ListT $ return Nil
    u `mplus` v = ListT $ runListT u >>= \case
        Nil -> runListT v
        Cons a u' -> return (Cons a (u' `mplus` v))

-- The effects are kept apart, and can be consumed as they are needed.
instance Monad m => Monad (ListT m) where
    return a = ListT $ pure (Cons a mzero)
    u >>= f = ListT $ runListT u >>= \case
        Nil -> return Nil
        Cons a v -> runListT $ f a `mplus` (v >>= f)

instance MonadTrans ListT where
    lift m = ListT $ (\a -> Cons a mzero) <$> m

-- Building an effectful list from a seed.
unfoldM :: Monad m => (b -> m (ListF a b)) -> b -> ListT m a
unfoldM f b = ListT $ fmap (unfoldM f) <$> f b

-- Building an effectful list from a list of effects.
-- Compare and contrast with sequenceA.
fromEffects :: Monad m => [m a] -> ListT m a
fromEffects = unfoldM $ \case
    [] -> return Nil
    m : ms -> (\a -> Cons a ms) <$> m

-- This corresponds to splitAt from list-t.
runSome :: Monad m => Int -> ListT m a -> m ([a], ListT m a)
runSome 0 u = return ([], u)
runSome n u = runListT u >>= \case
    Nil -> return ([], mzero)
    Cons a v -> runSome (n-1) v >>= \(as, w) -> return (a : as, w)

-- A demonstration of how this ListT doesn't break streaming. 
-- Even though u amounts to an infinite list of effects, we can choose to
-- consume only a handful of them, and still get the corresponding results. 
main = do
    let u = fromEffects $ (\a -> print a >> return a) <$> [1..]
    (as, _) <- runSome 10 u
    print (sum as)