Console interactivity in Netwire?

Question

I am testing with the Netwire haskell library and made it work with a simple time wire:

import Control.Wire
import Prelude hiding (         


        

Answer 1

If you don't want to block on input and output, don't block on input and output. To demonstrate how to hook up netwire to events, we'll make a little framework for running wires. We'll avoid blocking the stepping of the wire by performing all IO in separate threads.

From the netwire documentation, we are allowed to deconstruct Events if we are developing a framework.

Netwire does not export the constructors of the Event type by default. If you are a framework developer you can import the Control.Wire.Unsafe.Event module to implement your own events.

This lets us see that Event is just

data Event a = NoEvent | Event a

We will make a very simple framework that uses one action in m for input and one for output. It runs an action m (Either e a) to read an action or inhibit. It either runs an action b -> m () to output or stops when the wire inhibits.

import Control.Wire
import Prelude hiding ((.), id)

import Control.Wire.Unsafe.Event

run :: (HasTime t s, Monad m) =>
       m (Either e a) -> (b -> m ()) ->
       Session m s -> Wire s e m (Event a) (Event b) -> m e
run read write = go
    where
        go session wire = do
            (dt, session') <- stepSession session
            a <- read
            (wt', wire') <- stepWire wire dt (Event <$> a)
            case wt' of
                Left e -> return e
                Right bEvent -> do
                    case bEvent of
                        Event b -> write b
                        _       -> return ()
                    go session' wire'

We will use this to run an example program that outputs the time every second and stops (inhibits) when the 'x' key is pressed.

example :: (HasTime t s, Monad m, Show t) =>
           Wire s () m (Event [InputEvent]) (Event [OutputEvent])
example = switch $
            (fmap ((:[]) . print) <$> periodic 1 . time)
            &&&
            (fmap (const mkEmpty) <$> filterE (any (== KeyPressed 'x')))

The input and output events carry multiple events in case more than one event takes place in the same time step. The input events are just pressed character keys. The output events are IO actions.

data InputEvent = KeyPressed Char 
  deriving (Ord, Eq, Read, Show)
type OutputEvent = IO ()

Our non-blocking IO will run three threads: an input thread, an output thread, and a wire thread. They will communicate with each other by atomically modifying IORefs. This is overkill for an example program (we could have just used hReady when reading) and not enough for a production program (The IO threads will spin waiting on characters and output). In practice polling for events and scheduling output will usually be provided by some other IO framework (OpenGL, a gui toolkit, a game engine, etc).

import Data.IORef

type IOQueue a = IORef [a]

newIOQueue :: IO (IOQueue a)
newIOQueue = newIORef []

readIOQueue :: IOQueue a -> IO [a]
readIOQueue = flip atomicModifyIORef (\xs -> ([], reverse xs))

appendIOQueue :: IOQueue a -> [a] -> IO ()
appendIOQueue que new = atomicModifyIORef que (\xs -> (reverse new ++ xs, ()))

The main thread sets up the queues, spawns the IO threads, runs the wire, and signals the IO threads when the program has stopped.

import Control.Concurrent.MVar
import Control.Concurrent.Async

import Control.Monad.IO.Class

runKeyboard :: (HasTime t s, MonadIO m) =>
               Session m s -> Wire s e m (Event [InputEvent]) (Event [OutputEvent]) -> m e
runKeyboard session wire = do
    stopped <- liftIO newEmptyMVar 
    let continue = isEmptyMVar stopped
    inputEvents  <- liftIO newIOQueue
    outputEvents <- liftIO newIOQueue
    inputThread  <- liftIO $ async (readKeyboard continue (appendIOQueue inputEvents .    (:[])))
    outputThread <- liftIO $ async (runEvents    continue (sequence_ <$> readIOQueue outputEvents))
    let read  = liftIO $ Right <$> readIOQueue   inputEvents 
    let write = liftIO .           appendIOQueue outputEvents
    e <- run read write session wire
    liftIO $ putMVar stopped ()
    liftIO $ wait inputThread
    liftIO $ wait outputThread
    return e

The input thread waits for keys, spinning when there is no input ready. It sends KeyPressed events to the queue.

import System.IO

readKeyboard :: IO Bool -> (InputEvent -> IO ()) -> IO ()
readKeyboard continue send = do
    hSetBuffering stdin NoBuffering
    while continue $ do
        ifM (hReady stdin) $ do
            a <- getChar
            send (KeyPressed a)

ifM :: Monad m => m Bool -> m a -> m ()
ifM check act = do
    continue <- check
    if continue then act >> return () else return ()

while :: Monad m => m Bool -> m a -> m ()
while continue act = go
    where
        go = ifM continue loop
        loop = act >> go

The output thread runs the actions it is sent as long as it is instructed to continue (and once more after it is signaled to stop to make sure all the output happens).

runEvents :: IO Bool -> (IO (IO ())) -> IO ()
runEvents continue fetch = (while continue $ fetch >>= id) >> fetch >>= id

We can run the example program with runKeyboard.

main = runKeyboard clockSession_ example