gistfile1.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Keigoi 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

newtype R a = R { unR :: IO a } deriving (Monad)

runCharIO :: R a -> IO a
runCharIO = unR

instance CharActions R where
  getChar = R IO.getChar
  putChar c = R $ 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

newtype S a = S
  { unS :: ErrorT String (RWS () [String] String) a
  } deriving Monad

emulateCharIO :: S a -> String -> (Either String a, [String])
emulateCharIO (S prog) xs = evalRWS (runErrorT prog) () xs

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