gistfile1.hs

{-# LANGUAGE GADTs, FlexibleInstances #-}


module Main where

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

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

class Monad t => CharActions t where
    getChar :: t Char
    putChar :: Char -> t ()

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

runCharIO :: IO a -> IO a
runCharIO = id

instance CharActions IO where
  getChar = IO.getChar
  putChar c = IO.putChar c

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

echo :: CharActions t => t ()
echo = do
    getChar >>= putChar
    echo

echo1 :: CharActions t => t 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 :: ErrorT String (RWS () [String] String) a -> String -> (Either String a, [String])
emulateCharIO prog xs = evalRWS (runErrorT prog) () xs

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