ContT experiment

Cont.hs

{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Control.Monad.Cont
import Control.Monad.Reader
import Control.Monad.IO.Class
import qualified Data.Map.Strict as M

_chainCPS :: ((a -> r) -> r) -> (a -> ((b -> r) -> r)) -> ((b -> r) -> r)
--chainCPS car acbr = \br -> car (`acbr` br)
_chainCPS car acbr = \br -> car $ \a' -> acbr a' br

data T a = V a | P String | A String (T a)
  deriving (Eq,Show)


type Env = M.Map Int String
newtype Ev r a = Ev { unEv :: (ContT r (ReaderT Env IO) a) }
  deriving (Functor,Applicative,Monad,MonadIO,MonadCont,MonadReader Env)
--runEv :: Env ->  -> IO r
runEv :: Env -> Ev r a -> (a -> ReaderT Env IO r) -> IO r
runEv e act cc = runReaderT (runContT (unEv act) cc) e

red :: T Int -> (T Int -> Ev s (T Int)) -> Ev r (T Int)
red (V i) _ = P <$> reader (M.! i)
red (A f t) k = red t k >>= \t' -> do
  case f of
    "print" -> liftIO $ print t'
    _ -> return ()
  return t'
red t _ = return t


go = runEv (M.fromList [(0,"foo")]) (callCC $ red $ (A "print" (V (0 :: Int)))) (liftIO . print)