    {-# 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)       = (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)

    -- | 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    = 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 a. a -> IOSpec f a
    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  =   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 a. a -> IOSpec f a
    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
        c <- VM Char
    readChar
        return (Step (f c))
      step (PutChar Char
    c a
    a) = do
        Char -> VM ()
    printChar Char
    c
        Step a -> StateT Store Effect (Step a)
    forall a. a -> StateT Store Effect 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 :: forall (f :: * -> *). (Teletype :<: f) => 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 :: forall (f :: * -> *). (Teletype :<: f) => 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 a b. IOSpec f a -> IOSpec f b -> IOSpec f b
    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 :: forall (f :: * -> *). (Teletype :<: f) => IOSpec f String
    getLine = do
      c <- IOSpec f Char
    forall (f :: * -> *). (Teletype :<: f) => IOSpec f Char
    getChar
      if c == '\n'
        then return []
        else getLine >>= \String
    line -> String -> IOSpec f String
    forall a. a -> IOSpec f a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Char
    c Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    line)