State ~ Codensity Reader.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}

import Control.Monad.Reader
import Control.Monad.State

newtype Codensity m a = Codensity {runCodensity :: forall r. (a -> m r) -> m r}
  deriving stock (Functor)

instance Applicative (Codensity m) where
  pure x = Codensity \next -> next x
  (<*>) = ap

instance Monad (Codensity m) where
  Codensity x >>= f = Codensity \next -> x \a -> runCodensity (f a) next

instance MonadIO m => MonadIO (Codensity m) where
  liftIO = lift . liftIO

instance MonadTrans Codensity where
  lift m = Codensity \next -> do
    next =<< m

instance MonadReader e m => MonadReader e (Codensity m) where
  ask = lift ask
  local f act = Codensity \next -> do
    local f do
      runCodensity act next

instance Monad m => MonadState s (Codensity (ReaderT s m)) where
  get = ask
  put s = Codensity \next ->
    local (const s) do
      next ()

runCodStateT :: Monad m => Codensity (ReaderT s m) a -> s -> m (a, s)
runCodStateT m s = do
  flip runReaderT s do
    runCodensity m \a -> do
      s <- ask
      pure (a, s)

example :: (MonadIO m, MonadState Int m) => m String
example = do
  a <- get
  put (a + 1)
  a <- get
  liftIO (print a)
  pure "hello"

main = flip runCodStateT (41 :: Int) example

-- newtype CodStateT s m a = CodStateT (Codensity (ReaderT s m) a)
--   deriving newtype (Functor, Applicative, Monad, MonadIO)

-- instance Monad m => MonadState s (CodStateT s m) where
--   get = CodStateT ask
--   put s = CodStateT (Codensity (\next -> local (\_ -> s) (next ())))

-- runCodStateT :: Monad m => CodStateT s m a -> s -> m (a, s)
-- runCodStateT (CodStateT m) s = do
--   flip runReaderT s do
--     runCodensity m \a -> do
--       s <- ask
--       pure (a, s)

-- main = flip runCodStateT (41 :: Int) do
--   a <- get
--   put (a + 1)
--   a <- get
--   liftIO (print a)