Delimited continuation monad transformer

cont.hs

{- cabal:
build-depends: base
-}

module ContT
    ( ContT
    , reset
    , shift
    , liftIO
    )
where

import Data.Functor.Identity

-- * ContT continuation monad transformer.
newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r }

-- It is 2020 and we are doing explicit type class instances.
instance Monad m => Functor (ContT r m) where
    fmap f c = ContT $ \k -> runContT c (k . f)

instance Monad m => Applicative (ContT r m) where
    pure x = ContT ($ x)
    f <*> v = ContT $ \c -> runContT f $ \g -> runContT v (c . g)
    m *> k = m >>= \_ -> k

instance Monad m => Monad (ContT r m) where
    return x = ContT $ \k -> k x
    m >>= k = _join (fmap k m) where
        _join :: ContT r m (ContT r m a) -> ContT r m a
        _join cc = ContT $ \c -> runContT cc (\x -> runContT x c)

-- Dynamically limits the extent of a continuation.
reset :: Monad m => ContT a m a -> m a
reset cc = runContT cc return

-- Captures the reified continuation up to the innermost enclosing reset.
shift :: Monad m => ((a -> m r) -> ContT r m r) -> ContT r m a
shift e = ContT $ \k -> reset (e k)

-- If you have to pick one monad to sit atop why not pick IO?
liftIO :: IO a -> ContT r IO a
liftIO x = ContT (x >>=)

-- * Examples!

-- | Interleaves IO and control flow side effects to produce a result.
sixteen :: ContT Int IO Int
sixteen = do
    n <- shift $ \k -> liftIO $ do
        x <- k 4
        putStrLn ("(k 4) = " ++ show x)
        y <- k x
        putStrLn ("(k (k 4)) = " ++ show y)
        return y
    liftIO $ putStrLn "This is printed twice"
    return (n * 2) -- this will be k's return value above

-- | 
seventeen :: IO Int
seventeen = do
    _16 <- reset sixteen
    return (_16 + 1)

{-
reset :: Cont a a -> a
reset cc = runCont cc id

shift :: ((a -> r) -> Cont r r) -> Cont r a
shift e = Cont $ \k -> reset (e k)
-}