haskell - 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 ((.), id)

import Control.Monad.IO.Class
import Data.Functor.Identity
import System.IO

wire :: (HasTime t s) => Wire s () m a t
wire = time

run :: (HasTime t s, MonadIO m, Show b, Show e) =>
       Session m s -> Wire s e m a b -> m ()
run session wire = do
  (dt, session') <- stepSession session
  (wt', wire') <- stepWire wire dt $ Right undefined
  case wt' of
    -- | Exit
    Left _ -> return ()
    Right x -> do
      liftIO $ do
        putChar '
'
        putStr $ either (ex -> show ex) show wt'
        hFlush stdout
        -- Interactivity here?
        gotInput <- hReady stdin
        if gotInput then
          return ()
          else return ()
      run session' wire'

main :: IO ()
-- main = testWire clockSession_ wire
main = run clockSession_ wire

Note: the run is basically modified from testWire, so I don't know if it is the correct way to form a network of wires. Part of the code origin from http://todayincode.tumblr.com/post/96914679355/almost-a-netwire-5-tutorial but that tutorial does not say about events.

Now I am trying to add a bit interactivity to the program. For now, quit the program when any key is pressed. I suppose I should do some event switching. However, I am stuck here because I cannot find a way to either change wire' or switch the behaviour. I tried to read the API document and the source, but I don't see how to actually "fire" an Event or using it to switch the wire.

Again, since I am not yet very familiar with Haskell, I may have made some big stupid mistakes here.

Update 1/2

I got my goal working by the following code. The timer stops on any key press. Update 2 I managed to separate out pollInput into another IO only function, Yay!

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

import Control.Monad.IO.Class
import Data.Functor.Identity
import System.IO

wire :: (HasTime t s) => Wire s () m a t
wire = time

run :: (HasTime t s, MonadIO m, Show b, Show e) =>
       Session m s -> Wire s e m a b -> m ()
run session wire = do
  -- Get input here
  input <- liftIO $ pollInput

  (dt, session') <- stepSession session
  (wt', wire') <- stepWire wire dt $ input
  case wt' of
    -- | Exit
    Left _ -> liftIO (putStrLn "") >> return ()
    Right x -> do
      liftIO $ do
        putChar '
'
        putStr $ either (ex -> show ex) show wt'
        hFlush stdout

      run session' wire'

pollInput :: IO (Either a b)
pollInput =  do
  gotInput <- hReady stdin
  if gotInput then
    return (Left undefined)
    else return (Right undefined)


setup :: IO ()
setup = do
  hSetBuffering stdin NoBuffering
  hSetBuffering stdout NoBuffering


main :: IO ()
main = do
  setup
  run clockSession_ wire

However, this raises some further questions. First, is this good practise? Second, what is the type of pollInput? I tried to manually type it out but without success. Automatic type deduction works, though.

This is my explanation of how this code works:

First, the user input from console is polled, and after some logic, the "input" to wire is generated (poor name choice, but that input generated is the wire input) and passed along the network. Here, I simply pass an inhibition (Left something), and will cause the loop to exit. Of course, when exiting, the program produces a newline to make console look nicer.

(Well, I still don't understand how Event works, though)

Update 3/4

After reading @Cirdec 's answer, and fiddled a lot on my editor, I get this single threaded version without IORef, also quitting on pressing 'x'Update 4: (but it does not output anything):

import Control.Wire
import Prelude hiding ((.),id)
import Control.Wire.Unsafe.Event
import System.IO
import Control.Monad.IO.Class

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

--- Wires
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'))
           )

readKeyboard :: IO (Either e (InputEvent))
readKeyboard = do
  hSetBuffering stdin NoBuffering
  gotInput <- hReady stdin
  if gotInput then do
    c <- getChar
    return $ Right $ KeyPressed c
    else return $ Right $ NoKeyPressed

output :: [OutputEvent] -> IO ()
output (x:xs) = id x >> output xs
output _ = return ()

run :: (HasTime t s, MonadIO m) =>
       Session m s -> Wire s e m (Event [InputEvent]) (Event [OutputEvent]) -> m e
run = go
  where
    go session wire = do
      -- | inputEvent :: Event InputEvent
      inputEvent <- liftIO $ readKeyboard
      (dt, session') <- stepSession session
      (wt', wire') <- stepWire wire dt (Event <$> (fmap (:[]) inputEvent))
      -- (wt', wire') <- stepWire wire dt (Right undefined)
      case wt' of
        Left a -> return a
        Right bEvent -> do
          case bEvent of
            Event b -> liftIO $ output b
            _ -> return ()
          go session' wire'

main = do
  run clockSession_ example

I think this is much better than my original, but I am still not completely convinced whether it is good practise or not.

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