Интерактивность консоли в Netwire?

Если вы не хотите блокировать вход и выход, не блокируйте вход и выход. Чтобы продемонстрировать, как подключить netwire к событиям, мы сделаем небольшую структуру для запуска проводов. Мы избежим блокировки шага проволоки, выполнив все IO в отдельных потоках.

Из документации netwire, нам разрешено деконструировать Event s, Если мы разрабатываем фреймворк.

Netwire не экспортирует конструкторы типа Event по по умолчанию. Если вы являетесь разработчиком фреймворка, вы можете импортировать модуль Control.Wire.Unsafe.Event для реализации собственных событий.

Это позволяет нам увидеть, что Event это просто

data Event a = NoEvent | Event a

Мы сделаем очень простую структуру, которая использует одно действие в m для ввода и одно для вывода. Он запускает действие m (Either e a), чтобы прочитать действие или запретить. Он либо выполняет действие b -> m () для вывода, либо останавливается, когда провод тормозит.

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'

Мы будем использовать это для запуска примера программы, которая выводит время каждую секунду и останавливается (тормозит) при нажатии клавиши 'x'.

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

Входные и выходные события содержат несколько событий, если на одном и том же временном шаге происходит более одного события. Входные события - это просто нажатые клавиши символов. Выходными событиями являются действия IO.

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

Наш неблокирующий IO будет работать с тремя потоками: входным потоком, выходным потоком и проводным потоком. Они будут общаться друг с другом, атомарно модифицируя IORefС. перебор для примера программы (мы могли бы просто использовать hReady при чтении) и недостаточно для производственной программы (потоки ввода-вывода будут вращаться в ожидании символов и вывода). На практике опрос событий и планирование выходных данных обычно обеспечивается какой-либо другой платформой ввода-вывода (OpenGL, инструментарий gui, игровой движок и т. д.).

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, ()))

Основной поток устанавливает очереди, порождает потоки ввода-вывода, запускает провод и сигнализирует потокам ввода-вывода, когда программа имеет остановился.

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

Входной поток ждет ключей, вращаясь, когда нет готового ввода. Он отправляет события KeyPressed в очередь.

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

Выходной поток выполняет действия, которые он посылает, пока ему не будет дана команда продолжить (и еще раз после того, как он подаст сигнал остановиться, чтобы убедиться, что все выходные данные выполняются).

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

Мы можем запустить пример программы с помощью runKeyboard.

main = runKeyboard clockSession_ example