{-# LANGUAGE FlexibleContexts, TypeOperators #-}
-- | A pure specification of getChar and putChar.
module Test.IOSpec.Teletype
   (
   -- * The IOTeletype monad
     Teletype
   -- * Pure getChar and putChar
   , 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

-- The 'Teletype' specification.
--
-- | An expression of type 'IOSpec' 'Teletype' @a@ corresponds to an @IO@
-- computation that may print to or read from stdout and stdin
-- respectively.
--
-- There is a minor caveat here. I assume that stdin and stdout are
-- not buffered. This is not the standard behaviour in many Haskell
-- compilers.
data Teletype a =
     GetChar (Char -> a)
  |  PutChar Char a

instance Functor Teletype where
  fmap :: forall a b. (a -> b) -> Teletype a -> Teletype b
fmap a -> b
f (GetChar Char -> a
tt)       = forall a. (Char -> a) -> Teletype a
GetChar (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> a
tt)
  fmap a -> b
f (PutChar Char
c a
tt)     = forall a. Char -> a -> Teletype a
PutChar Char
c (a -> b
f a
tt)

-- | The 'getChar' function can be used to read a character from the
-- teletype.
getChar    :: (:<:) Teletype f => IOSpec f Char
getChar :: forall (f :: * -> *). (Teletype :<: f) => IOSpec f Char
getChar    = forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (IOSpec f a) -> IOSpec f a
inject (forall a. (Char -> a) -> Teletype a
GetChar forall (m :: * -> *) a. Monad m => a -> m a
return)

-- | The 'getChar' function can be used to print a character to the
-- teletype.
putChar    ::  (Teletype :<: f) => Char -> IOSpec f ()
putChar :: forall (f :: * -> *). (Teletype :<: f) => Char -> IOSpec f ()
putChar Char
c  =   forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (IOSpec f a) -> IOSpec f a
inject (forall a. Char -> a -> Teletype a
PutChar Char
c (forall (m :: * -> *) a. Monad m => a -> m a
return ()))

instance Executable Teletype where
  step :: forall a. Teletype a -> VM (Step a)
step (GetChar Char -> a
f)   = do
    Char
c <- VM Char
readChar
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Step a
Step (Char -> a
f Char
c))
  step (PutChar Char
c a
a) = do
    Char -> VM ()
printChar Char
c
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Step a
Step a
a)

putStr :: (Teletype :<: f) => String -> IOSpec f ()
putStr :: forall (f :: * -> *). (Teletype :<: f) => String -> IOSpec f ()
putStr String
str = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ String
str forall (f :: * -> *). (Teletype :<: f) => Char -> IOSpec f ()
putChar

putStrLn :: (Teletype :<: f) => String -> IOSpec f ()
putStrLn :: forall (f :: * -> *). (Teletype :<: f) => String -> IOSpec f ()
putStrLn String
str = forall (f :: * -> *). (Teletype :<: f) => String -> IOSpec f ()
putStr String
str forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *). (Teletype :<: f) => Char -> IOSpec f ()
putChar Char
'\n'

getLine :: (Teletype :<: f) => IOSpec f String
getLine :: forall (f :: * -> *). (Teletype :<: f) => IOSpec f String
getLine = do
  Char
c <- forall (f :: * -> *). (Teletype :<: f) => IOSpec f Char
getChar
  if Char
c forall a. Eq a => a -> a -> Bool
== Char
'\n'
    then forall (m :: * -> *) a. Monad m => a -> m a
return []
    else forall (f :: * -> *). (Teletype :<: f) => IOSpec f String
getLine forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
line -> forall (m :: * -> *) a. Monad m => a -> m a
return (Char
c forall a. a -> [a] -> [a]
: String
line)