{-# LANGUAGE FlexibleContexts, TypeOperators #-}
module Test.IOSpec.Teletype
(
Teletype
, getChar
, putChar
, putStr
, putStrLn
, getLine
)
where
import Prelude hiding (getChar, putChar, putStr, putStrLn, getLine)
import Control.Monad (forM_)
import Test.IOSpec.Types
import Test.IOSpec.VirtualMachine
data Teletype a =
GetChar (Char -> a)
| PutChar Char a
instance Functor Teletype where
fmap :: (a -> b) -> Teletype a -> Teletype b
fmap a -> b
f (GetChar Char -> a
tt) = (Char -> b) -> Teletype b
forall a. (Char -> a) -> Teletype a
GetChar (a -> b
f (a -> b) -> (Char -> a) -> Char -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> a
tt)
fmap a -> b
f (PutChar Char
c a
tt) = Char -> b -> Teletype b
forall a. Char -> a -> Teletype a
PutChar Char
c (a -> b
f a
tt)
getChar :: (:<:) Teletype f => IOSpec f Char
getChar :: IOSpec f Char
getChar = Teletype (IOSpec f Char) -> IOSpec f Char
forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (IOSpec f a) -> IOSpec f a
inject ((Char -> IOSpec f Char) -> Teletype (IOSpec f Char)
forall a. (Char -> a) -> Teletype a
GetChar Char -> IOSpec f Char
forall (m :: * -> *) a. Monad m => a -> m a
return)
putChar :: (Teletype :<: f) => Char -> IOSpec f ()
putChar :: Char -> IOSpec f ()
putChar Char
c = Teletype (IOSpec f ()) -> IOSpec f ()
forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (IOSpec f a) -> IOSpec f a
inject (Char -> IOSpec f () -> Teletype (IOSpec f ())
forall a. Char -> a -> Teletype a
PutChar Char
c (() -> IOSpec f ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
instance Executable Teletype where
step :: Teletype a -> VM (Step a)
step (GetChar Char -> a
f) = do
Char
c <- VM Char
readChar
Step a -> VM (Step a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Step a
forall a. a -> Step a
Step (Char -> a
f Char
c))
step (PutChar Char
c a
a) = do
Char -> VM ()
printChar Char
c
Step a -> VM (Step a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Step a
forall a. a -> Step a
Step a
a)
putStr :: (Teletype :<: f) => String -> IOSpec f ()
putStr :: String -> IOSpec f ()
putStr String
str = String -> (Char -> IOSpec f ()) -> IOSpec f ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ String
str Char -> IOSpec f ()
forall (f :: * -> *). (Teletype :<: f) => Char -> IOSpec f ()
putChar
putStrLn :: (Teletype :<: f) => String -> IOSpec f ()
putStrLn :: String -> IOSpec f ()
putStrLn String
str = String -> IOSpec f ()
forall (f :: * -> *). (Teletype :<: f) => String -> IOSpec f ()
putStr String
str IOSpec f () -> IOSpec f () -> IOSpec f ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> IOSpec f ()
forall (f :: * -> *). (Teletype :<: f) => Char -> IOSpec f ()
putChar Char
'\n'
getLine :: (Teletype :<: f) => IOSpec f String
getLine :: IOSpec f String
getLine = do
Char
c <- IOSpec f Char
forall (f :: * -> *). (Teletype :<: f) => IOSpec f Char
getChar
if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'
then String -> IOSpec f String
forall (m :: * -> *) a. Monad m => a -> m a
return []
else IOSpec f String
forall (f :: * -> *). (Teletype :<: f) => IOSpec f String
getLine IOSpec f String -> (String -> IOSpec f String) -> IOSpec f String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
line -> String -> IOSpec f String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
line)