Support concurrent operation

programs/Main.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
 
+import Control.Concurrent
 import Data.Default
+import Data.Monoid
 import Graphics.Vty
 import System.Exit
 
@@ -11,6 +13,7 @@ data St =
     St { focus :: FocusRing
        , stEditor :: Editor
        , trans :: Location
+       , counter :: Int
        }
 
 eName :: Name
@@ -21,39 +24,57 @@ drawUI st = [top]
     where
         top = translated (trans st) $
               hLimit 40 $
-              vBox [ "Top"
+              vBox [ txt $ "Top (counter: " <> show (counter st) <> ")"
                    , hBorder '-'
                    , hBox [ " Edit: "
                           , hLimit 20 $ edit (stEditor st) `withAttr` (cyan `on` blue)
                           ]
                    ]
 
-handleEvent :: Event -> St -> IO St
+handleEvent :: MyEvent -> St -> IO St
 handleEvent e st =
     case e of
-        EvKey KEsc [] -> exitSuccess
-        EvKey KEnter [] -> error $ editStr $ stEditor st
-        EvKey KLeft [MCtrl] -> return $ st { trans = trans st `locOffset` (Location (-1, 0)) }
-        EvKey KRight [MCtrl] -> return $ st { trans = trans st `locOffset` (Location (1, 0)) }
-        EvKey KUp [MCtrl] -> return $ st { trans = trans st `locOffset` (Location (0, -1)) }
-        EvKey KDown [MCtrl] -> return $ st { trans = trans st `locOffset` (Location (0, 1)) }
-        ev -> return $ st { stEditor = editEvent ev (stEditor st) }
+        VtyEvent vtyEv ->
+            case vtyEv of
+                EvKey KEsc [] -> exitSuccess
+                EvKey KEnter [] -> error $ editStr $ stEditor st
+                EvKey KLeft [MCtrl] -> return $ st { trans = trans st `locOffset` (Location (-1, 0)) }
+                EvKey KRight [MCtrl] -> return $ st { trans = trans st `locOffset` (Location (1, 0)) }
+                EvKey KUp [MCtrl] -> return $ st { trans = trans st `locOffset` (Location (0, -1)) }
+                EvKey KDown [MCtrl] -> return $ st { trans = trans st `locOffset` (Location (0, 1)) }
+                ev -> return $ st { stEditor = editEvent ev (stEditor st) }
+        CounterUpdate i -> return $ st { counter = i }
 
 initialState :: St
 initialState =
     St { focus = focusRing [eName]
        , stEditor = editor eName ""
        , trans = Location (0, 0)
+       , counter = 0
        }
 
-app :: App St
-app =
+data MyEvent = VtyEvent Event
+             | CounterUpdate Int
+
+theApp :: App St MyEvent
+theApp =
     def { appDraw = drawUI
         , appChooseCursor = focusRingCursor focus
         , appHandleEvent = handleEvent
         }
 
+updateThread :: Chan MyEvent -> IO ()
+updateThread chan = do
+    let run i = do
+                 writeChan chan $ CounterUpdate i
+                 threadDelay 1000000
+                 run $ i + 1
+    run 0
+
 main :: IO ()
-main = standardIOConfig
-       >>= mkVty
-       >>= runVty app initialState
+main = do
+    chan <- newChan
+    withVty (mkVty def) $ \vty -> do
+        forkIO $ supplyVtyEvents vty VtyEvent chan
+        forkIO $ updateThread chan
+        runVty vty chan theApp initialState

src/Brick.hs

@@ -4,7 +4,9 @@ module Brick where
 
 import Control.Applicative hiding ((<|>))
 import Control.Arrow ((>>>))
+import Control.Concurrent
 import Control.Exception (finally)
+import Control.Monad (forever)
 import Data.Default
 import Data.Maybe
 import Data.String
@@ -52,14 +54,14 @@ instance Default Widget where
                  , widgetName = Nothing
                  }
 
-data App a =
+data App a e =
     App { appDraw :: a -> [Widget]
         , appChooseCursor :: a -> [CursorLocation] -> Maybe CursorLocation
-        , appHandleEvent :: Event -> a -> IO a
+        , appHandleEvent :: e -> a -> IO a
         , appHandleResize :: Name -> DisplayRegion -> a -> a
         }
 
-instance Default (App a) where
+instance Default (App a e) where
     def = App { appDraw = const def
               , appChooseCursor = const $ const Nothing
               , appHandleEvent = const return
@@ -308,21 +310,48 @@ withCursor w cursorLoc =
                                     }
       }
 
-runVty :: App a -> a -> Vty -> IO ()
-runVty app initialState vty = do
-    let run state = do
-          sz <- displayBounds $ outputIface vty
-          let (pic, sizes) = renderFinal (appDraw app state) sz (appChooseCursor app state)
-          update vty pic
+defaultMain :: App a Event -> a -> IO ()
+defaultMain = defaultMainWithVty (mkVty def)
 
-          let !applyResizes = foldl (>>>) id $ (uncurry (appHandleResize app)) <$> sizes
-              !resizedState = applyResizes state
+defaultMainWithVty :: IO Vty -> App a Event -> a -> IO ()
+defaultMainWithVty buildVty app initialState = do
+    chan <- newChan
+    withVty buildVty $ \vty -> do
+        forkIO $ supplyVtyEvents vty id chan
+        runVty vty chan app initialState
 
-          e <- nextEvent vty
-          newState <- appHandleEvent app e resizedState
-          run newState
+supplyVtyEvents :: Vty -> (Event -> e) -> Chan e -> IO ()
+supplyVtyEvents vty mkEvent chan =
+    forever $ do
+        e <- nextEvent vty
+        writeChan chan $ mkEvent e
 
-    run initialState `finally` (shutdown vty)
+runVty :: Vty -> Chan e -> App a e -> a -> IO ()
+runVty vty chan app state = do
+    state' <- renderApp vty app state
+    e <- readChan chan
+    appHandleEvent app e state' >>= runVty vty chan app
+
+withVty :: IO Vty -> (Vty -> IO a) -> IO a
+withVty buildVty useVty = do
+    vty <- buildVty
+    useVty vty `finally` shutdown vty
+
+renderApp :: Vty -> App a e -> a -> IO a
+renderApp vty app state = do
+    sz <- displayBounds $ outputIface vty
+    let (pic, sizes) = renderFinal (appDraw app state) sz (appChooseCursor app state)
+    update vty pic
+
+    let !applyResizes = foldl (>>>) id $ (uncurry (appHandleResize app)) <$> sizes
+        !resizedState = applyResizes state
+
+    return resizedState
+
+getNextEvent :: Vty -> App a Event -> a -> IO a
+getNextEvent vty app state = do
+    e <- nextEvent vty
+    appHandleEvent app e state
 
 focusRing :: [Name] -> FocusRing
 focusRing [] = FocusRingEmpty