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

Answer 2

First, I would point to Kleisli Arrow in Netwire 5?. I came up with that answer after a longggg time of trying to understand Monads and Arrows. I will put a minimal example using Kleisli Wire soon.

This program merely echos what the user types, and quits when it hits a q. Though useless, it demonstrates a probably good practice of using Netwire 5.

mkKleisli :: (Monad m, Monoid e) => (a -> m b) -> Wire s e m a b
mkKleisli f = mkGen_ $ \a -> liftM Right $ f a

This is the Kleisli wire constructor written in the answer in the post referenced. In summary, this function lifts any Kleisli function a -> m b into Wire s e m a b. This is the core about any I/O we are doing in this program.

Since we are echoing as user types, hGetChar is probably the best choice. Therefore, we lift that into a wire.

inputWire :: Wire s () IO () Char
inputWire = mkKleisli $ \_ -> hGetChar stdin

Similarly, we use the following wire to output characters on screen.

outputWire :: Wire s () IO Char ()
outputWire = mkKleisli $ putChar

Then to determine when we need to quit, a pure wire is constructed to output True when q is the input (Note that mkSF_ can be used instead of arr).

quitWire :: (Monad m, Monoid e) => Wire s e m Char Bool
quitWire = arr $ quitNow
    where 
      quitNow c 
          | c == 'q' || c == 'Q' = True
          | otherwise = False

To actually use the information of quitting, we need to write a special (but really simple) runWire function which runs a wire of type Wire s e m () Bool. When the wire is inhibited or returns false, the function ends.

runWire :: (Monad m) => Session m s -> Wire s e m () Bool -> m ()
runWire s w = do
  (ds, s') <- stepSession s
  (quitNow, w') <- stepWire w ds (Right ())
  case quitNow of
    Right False -> runWire s' w'
    _ -> return ()

Now, let's put wires together.

mainWire = inputWire >>> (quitWire &&& outputWire) >>> arr (\(q,_) -> q)

Of course we can use the Arrow syntax:

mainWire = proc _ -> do 
  c <- inputWire -< ()
  q <- quitWire -< c
  outputWire -< c
  returnA -< q

Not sure if the proc version is faster or not, but in this simple example, both are quite readable.

We get input from inputWire, feed it to both quitWire and outputWire and get a tuple (Bool, ()). Then we take the first one as the final output.

At last, we run everything in main!

main = do 
  hSetEcho stdin False 
  hSetBuffering stdin NoBuffering
  hSetBuffering stdout NoBuffering 
  runWire clockSession_ mainWire

Here comes the final code I used:

{-# LANGUAGE Arrows #-}

module Main where

import Control.Wire
import Control.Monad
import Control.Arrow
import System.IO
import Prelude hiding ((.), id)

mkKleisli :: (Monad m, Monoid e) => (a -> m b) -> Wire s e m a b
mkKleisli f = mkGen_ $ \a -> liftM Right $ f a

inputWire :: Wire s () IO () Char
inputWire = mkKleisli $ \_ -> hGetChar stdin

outputWire :: Wire s () IO Char ()
outputWire = mkKleisli $ putChar

quitWire :: (Monad m, Monoid e) => Wire s e m Char Bool
quitWire = arr $ quitNow
    where 
      quitNow c 
          | c == 'q' || c == 'Q' = True
          | otherwise = False

runWire :: (Monad m) => Session m s -> Wire s e m () Bool -> m ()
runWire s w = do
  (ds, s') <- stepSession s
  (quitNow, w') <- stepWire w ds (Right ())
  case quitNow of
    Right False -> runWire s' w'
    _ -> return ()

mainWire = inputWire >>> (quitWire &&& outputWire) >>> arr (\(q,_) -> q)

main = do 
  hSetEcho stdin False 
  hSetBuffering stdin NoBuffering
  hSetBuffering stdout NoBuffering 
  runWire clockSession_ mainWire