An example for Operational Monad with two interpreters.

gistfile1.hs

{-# LANGUAGE GADTs #-}

module Main where

import Control.Monad
import Control.Monad.RWS.Strict
import Control.Monad.Trans.Error
import Control.Monad.Operational.Simple
import Prelude hiding (putChar, getChar)
import qualified System.IO as IO
import Test.QuickCheck

----------------------------------------------------------------
-- Our DSL

type CharIO = Program CharActions

data CharActions a where
    GetChar :: CharActions Char
    PutChar :: Char -> CharActions ()

----------------------------------------------------------------
-- APIs of our DSL

getChar :: Program CharActions Char
getChar = singleton GetChar

putChar :: Char -> Program CharActions ()
putChar = singleton . PutChar

----------------------------------------------------------------
-- Running our DSL in IO

runCharIO :: CharIO a -> IO a
runCharIO = interpret toIO

toIO :: CharActions a -> IO a
toIO GetChar = IO.getChar
toIO (PutChar c) = IO.putChar c

----------------------------------------------------------------
-- Example code

echo :: CharIO ()
echo = do
    getChar >>= putChar
    echo

echo1 :: CharIO Int
echo1 = do
    getChar >>= putChar
    return 1

----------------------------------------------------------------
-- IO

main :: IO ()
main = runCharIO echo

----------------------------------------------------------------
-- Testing purely

copy :: String -> (Either String a, [String])
copy []     = (Left "Eof", [])
copy (c:cs) = (r, "GetChar":("PutChar " ++ show c):xs)
  where
    (r,xs) = copy cs

prop_echo :: String -> Bool
prop_echo xs = emulateCharIO echo xs == copy xs

test :: IO ()
test = quickCheck prop_echo

----------------------------------------------------------------
-- Running our DSL purely

emulateCharIO :: Program CharActions a -> String -> (Either String a, [String])
emulateCharIO prog xs = evalRWS (runErrorT (interpret emulate prog)) () xs

emulate :: CharActions a -> ErrorT String (RWS () [String] String) a
emulate GetChar = get >>= getchar
  where
    getchar []     = throwError "Eof"
    getchar (x:xs) = tell ["GetChar"] >> put xs >> return x
emulate (PutChar x) = tell ["PutChar " ++ show x]