Computational effects: eff EDSL in Haskell

EffectExamples.hs

{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}
module Main where

import Effects

import Prelude hiding (catch)

import Control.Monad.Trans.Class (lift)
import qualified Data.Set as Set
import Data.Monoid
import Data.Void


testIO :: IO ()
testIO = runIO $ do
  io $ putStrLn "What's your name?"
  name <- io getLine
  io $ putStrLn $ "Hello, " ++ name


get :: (c ~ ContT (s -> m r) m, AutoLift c n, Monad m) => Proxy c -> n s
get p = operation p $ \k -> return $ \s -> do r <- k s; r s

put :: (c ~ ContT (s -> m r) m, AutoLift c n, Monad m) => Proxy c -> s -> n ()
put p s' = operation p $ \k -> return $ \_ -> do r <- k (); r s'

ref :: Monad m => s -> Handler (s -> m a) m a a
ref s_init = Handler
  { ret = return . return . return
  , fin = \f -> f s_init
  }
  
testRef :: (Int, Int)
testRef = run $ do
  with (ref 10) $ \u -> do
    with (ref 20) $ \v -> do
      w <- get u
      put u (w + 5)
      x <- get v
      put v (x + 1)
      y <- get u
      z <- get v
      return (y, z)



tell :: (c ~ ContT (w, r) m, AutoLift c n, Monad m, Monoid w) => Proxy c -> w -> n ()
tell p w = operation p $ \k -> do (w', r) <- k (); return (w `mappend` w', r)

writer :: (Monad m, Monoid w) => Handler (w, a) m a (w, a)
writer = Handler
  { ret = \a -> return (mempty, a)
  , fin = return
  }
  
testWriter :: (String, (String, Int))
testWriter = run $ do
  with writer $ \w1 -> do
    with writer $ \w2 -> do
      tell w1 "123"
      tell w2 "abc"
      tell w1 "456"
      tell w2 "def"
      return 1


choose :: (c ~ ContT (Set.Set r) m, AutoLift c n, Monad m, Ord r) 
       => Proxy c -> [a] -> n a
choose p as = operation p $ \k -> do
  sets <- mapM k as
  return $ Set.unions sets

set :: (Monad m, Ord a) => Handler (Set.Set a) m a (Set.Set a)
set = Handler
  { ret = return . Set.singleton
  , fin = return
  }

testSet :: Set.Set Int
testSet = run $
  with set $ \s -> do
    x <- choose s [1, 2]
    y <- choose s [1, 2]
    z <- choose s [1, 2]
    return $ x * x - y * z * x + z * z * z - y * y * x
  


throw :: (c ~ ContT ((e -> m r) -> m r) m, AutoLift c n, Monad m) => Proxy c -> e -> n Void
throw p e = operation p $ \_ -> return $ \h -> h e

catch :: Monad m => (e -> m a) -> Handler ((e -> m a) -> m a) m a a
catch h = Handler
  { ret = return . return . return
  , fin = \f -> f h
  }

testCatch :: IO ()
testCatch = runIO $ do
  with (catch (\e -> io $ putStrLn ("Error: " ++ e))) $ \c -> do
    io $ putStrLn "before"
    throw c "123"
    io $ putStrLn "after"
  

throw1 :: (c ~ ContT (Either e (m r)) m, AutoLift c n, Monad m) => Proxy c -> e -> n Void
throw1 p e = operation p $ \_ -> return $ Left e

catch1 :: Monad m => (e -> m a) -> Handler (Either e (m a)) m a a
catch1 h = Handler
  { ret = return . return . return
  , fin = either h id
  }

testCatch1 :: IO ()
testCatch1 = runIO $ do
  with (catch1 (\e -> io $ putStrLn ("Error: " ++ e))) $ \c -> do
    io $ putStrLn "before"
    throw1 c "123"
    io $ putStrLn "after"



shift :: (c ~ ContT r m, AutoLift c n, Monad m) => Proxy c -> ((m a -> m r) -> m r) -> n a
shift p c = operation p $ \k -> c (>>= k)

reset :: Monad m => Handler a m a a
reset = Handler
  { ret = return
  , fin = return
  }

testReset1 :: Int
testReset1 = run $ do
  with reset $ \r -> do
    x <- shift r (\k -> k (k (k (return 7))))
    return $ x * 2 + 1

testReset2 :: IO ()
testReset2 = runIO $ do
  r <- with reset $ \promptA -> do
    io $ putStrLn "Batman"
    with reset $ \promptB -> do
      shift promptB $ \k -> k (k (shift promptA $ \l -> l (l (return ()))))
      io $ putStrLn "Robin"
    io $ putStrLn "Cat woman"
  io $ print r

Effects.hs

{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, ScopedTypeVariables, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
module Effects (Handler(..), with, operation, run, runIO, io, ioHandler, Cont, ContT, Proxy, AutoLift) where

import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Cont
import Data.Functor.Identity

data Handler e m a r = Handler
  { ret :: a -> m e
  , fin :: e -> m r
  }

with :: Monad m => Handler e m a r -> (Proxy (ContT e m) -> ContT e m a) -> m r
with h f = runContT (f Proxy) (ret h) >>= fin h

operation :: forall m m' n a r. (m ~ ContT r m', AutoLift m n) => Proxy m -> ((a -> m' r) -> m' r) -> n a
operation p f = autolift p (Proxy :: Proxy n) (ContT f)

run :: Cont a a -> a
run m = runCont m id


ioHandler :: Handler a IO a a
ioHandler = Handler return return

runIO :: ContT () IO () -> IO ()
runIO m = with ioHandler (const m)

io :: AutoLift (ContT () IO) n => IO a -> n a
io m = operation (Proxy :: Proxy (ContT () IO)) (m >>=)


data Proxy (m :: * -> *) = Proxy

class AutoLift' m1 m2 n1 n2 where
  autolift' :: Proxy n1 -> Proxy n2 -> m1 a -> m2 a

instance (m1 ~ m2) => AutoLift' m1 m2 IO IO where
  autolift' Proxy Proxy = id
instance (m1 ~ m2) => AutoLift' m1 m2 Identity Identity where
  autolift' Proxy Proxy = id

pre :: Proxy (ContT r m) -> Proxy m
pre Proxy = Proxy
instance (AutoLift' m1 m2 IO n, Monad m2) => AutoLift' m1 (ContT r m2) IO (ContT s n) where
  autolift' p1 p2 = lift . autolift' p1 (pre p2)
instance (AutoLift' m1 m2 Identity n, Monad m2) => AutoLift' m1 (ContT r m2) Identity (ContT s n) where
  autolift' p1 p2 = lift . autolift' p1 (pre p2)

instance (AutoLift' m1 m2 n1 n2) => AutoLift' m1 m2 (ContT r1 n1) (ContT r2 n2) where
  autolift' p1 p2 = autolift' (pre p1) (pre p2)

class AutoLift m1 m2 where
  autolift :: Proxy m1 -> Proxy m2 -> m1 a -> m2 a
instance AutoLift' m1 m2 m1 m2 => AutoLift m1 m2 where
  autolift = autolift'