Merge pull request #45 from ethercrow/vty_async

Async refresh for vty frontend gives faster paste.

yi/src/library/Yi/UI/Vty.hs

@@ -46,14 +46,15 @@ data Rendered =
              , cursor  :: !(Maybe (Int,Int)) -- ^ cursor point on the above
              }
 
-data UI = UI {  vty       :: Vty             -- ^ Vty
-             , scrsize    :: IORef (Int,Int) -- ^ screen size
-             , uiThread   :: ThreadId
-             , uiEnd      :: MVar ()
-             , uiRefresh  :: MVar ()
-             , uiEditor   :: IORef Editor    -- ^ Copy of the editor state, local to the UI, used to show stuff when the window is resized.
-             , config     :: Config
-             , oAttrs     :: TerminalAttributes
+data UI = UI {  vty            :: Vty             -- ^ Vty
+             , scrsize         :: IORef (Int,Int) -- ^ screen size
+             , uiThread        :: ThreadId
+             , uiEndInputLoop  :: MVar ()
+             , uiEndRenderLoop :: MVar ()
+             , uiEditor        :: IORef Editor    -- ^ Copy of the editor state, local to the UI, used to show stuff when the window is resized.
+             , uiDirty         :: MVar ()         -- ^ used to trigger redraw in renderLoop
+             , config          :: Config
+             , oAttrs          :: TerminalAttributes
              }
 
 mkUI :: UI -> Common.UI
@@ -62,7 +63,7 @@ mkUI ui = Common.dummyUI
    Common.main           = main ui,
    Common.end            = end ui,
    Common.suspend        = raiseSignal sigTSTP,
-   Common.refresh        = refresh ui,
+   Common.refresh        = requestRefresh ui,
    Common.layout         = layout ui,
    Common.userForceRefresh = userForceRefresh ui
   }
@@ -81,51 +82,61 @@ start cfg ch outCh editor = do
           -- fork input-reading thread. important to block *thread* on getKey
           -- otherwise all threads will block waiting for input
           tid <- myThreadId
-          endUI <- newEmptyMVar
-          tuiRefresh <- newEmptyMVar
+          endInput <- newEmptyMVar
+          endRender <- newEmptyMVar
           editorRef <- newIORef editor
-          let result = UI v sz tid endUI tuiRefresh editorRef cfg oattr
+          dirty <- newEmptyMVar
+          let ui = UI v sz tid endInput endRender editorRef dirty cfg oattr
+
               -- | Action to read characters into a channel
-              getcLoop = maybe (getKey >>= ch >> getcLoop) (const (return ())) =<< tryTakeMVar endUI
+              inputLoop :: IO ()
+              inputLoop = tryTakeMVar endInput >>=
+                          maybe (getKey >>= ch >> inputLoop)
+                                (const $ return ())
 
               -- | Read a key. UIs need to define a method for getting events.
+              getKey :: IO Yi.Event.Event
               getKey = do 
                 event <- Vty.next_event v
                 case event of 
                   (EvResize x y) -> do
                       logPutStrLn $ "UI: EvResize: " ++ show (x,y)
                       writeIORef sz (y,x)
-                      outCh [makeAction (layoutAction result :: YiM ())] 
+                      outCh [makeAction (layoutAction ui :: YiM ())]
                       -- since any action will force a refresh, return () is probably 
-                      -- sufficient instead of "layoutAction result"
+                      -- sufficient instead of "layoutAction ui"
                       getKey
                   _ -> return (fromVtyEvent event)
-          discard $ forkIO getcLoop
-          return (mkUI result)
 
+              renderLoop :: IO ()
+              renderLoop = do
+                takeMVar dirty
+                tryTakeMVar endRender >>=
+                  maybe (do logPutStrLn "time to render"
+                            handle (\(except :: IOException) -> do
+                                       logPutStrLn "refresh crashed with IO Error"
+                                       logError $ show except)
+                                   (readIORef editorRef >>= refresh ui >> renderLoop))
+                        (const $ return ())
+
+          discard $ forkIO inputLoop
+          discard $ forkIO renderLoop
+
+          return (mkUI ui)
+
+-- Is there something else to do here?
+-- Previous version said "block on MVar forever" in rather obfuscated way
 main :: UI -> IO ()
-main ui = do
-  let
-      -- | When the editor state isn't being modified, refresh, then wait for
-      -- it to be modified again.
-      refreshLoop :: IO ()
-      refreshLoop = forever $ do
-                      logPutStrLn "waiting for refresh"
-                      takeMVar (uiRefresh ui)
-                      handle (\(except :: IOException) -> do
-                                 logPutStrLn "refresh crashed with IO Error"
-                                 logError $ show $ except)
-                             (readRef (uiEditor ui) >>= refresh ui >> return ())
-  logPutStrLn "refreshLoop started"
-  refreshLoop
+main _ui = forever $ threadDelay 1000000
 
 -- | Clean up and go home
 end :: UI -> Bool -> IO ()
-end i reallyQuit = do  
-  Vty.shutdown (vty i)
-  setTerminalAttributes stdInput (oAttrs i) Immediately
-  discard $ tryPutMVar (uiEnd i) ()
-  when reallyQuit $ throwTo (uiThread i) ExitSuccess
+end ui reallyQuit = do
+  Vty.shutdown (vty ui)
+  setTerminalAttributes stdInput (oAttrs ui) Immediately
+  discard $ tryPutMVar (uiEndInputLoop ui) ()
+  discard $ tryPutMVar (uiEndRenderLoop ui) ()
+  when reallyQuit $ throwTo (uiThread ui) ExitSuccess
   return ()
 
 fromVtyEvent :: Vty.Event -> Yi.Event.Event
@@ -192,6 +203,11 @@ layoutAction ui = do
     withEditor . put =<< io . layout ui =<< withEditor get
     withEditor $ mapM_ (flip withWindowE snapInsB) =<< getA windowsA
 
+requestRefresh :: UI -> Editor -> IO ()
+requestRefresh ui e = do
+  writeIORef (uiEditor ui) e
+  discard $ tryPutMVar (uiDirty ui) ()
+
 -- | Redraw the entire terminal from the UI.
 refresh :: UI -> Editor -> IO ()
 refresh ui e = do