From 2cd98a862c88069e3863ad0ad989dfa0e9081d29 Mon Sep 17 00:00:00 2001
From: Jonathan Daugherty <cygnus@foobox.com>
Date: Mon, 14 Mar 2022 12:56:27 -0700
Subject: [PATCH] Wrap internal events in a new InternalEvent type to improve
 how signal handling is done

This change modifies the Input type's event channel API to produce
InternalEvents, not Events. The new InternalEvent either wraps Event
with the InputEvent constructor (the previous behavior) or indicates
that Vty resumed after handling a signal using the ResumeAfterSignal
constructor. This change avoids the previous use of EvResize with lazy
exception arguments as a sentinel value for ResumeAfterSignal.
---
 src/Graphics/Vty.hs              | 19 +++++++++++--------
 src/Graphics/Vty/Input.hs        |  3 +--
 src/Graphics/Vty/Input/Events.hs | 10 ++++++++++
 src/Graphics/Vty/Input/Loop.hs   |  4 ++--
 4 files changed, 24 insertions(+), 12 deletions(-)

diff --git a/src/Graphics/Vty.hs b/src/Graphics/Vty.hs
index f92059e..f5342ed 100644
--- a/src/Graphics/Vty.hs
+++ b/src/Graphics/Vty.hs
@@ -48,6 +48,7 @@ where
 
 import Graphics.Vty.Config
 import Graphics.Vty.Input
+import Graphics.Vty.Input.Events
 import Graphics.Vty.Output
 import Graphics.Vty.Output.Interface
 import Graphics.Vty.Picture
@@ -209,16 +210,18 @@ internalMkVty input out = do
             maybe (return ()) innerUpdate mPic
 
     let mkResize = uncurry EvResize <$> displayBounds out
+
+        handleInternalEvent ResumeAfterSignal = mkResize
+        handleInternalEvent (InputEvent e)    = return e
+
         gkey = do
-            k <- atomically $ readTChan $ _eventChannel input
-            case k of
-                (EvResize _ _)  -> mkResize
-                _ -> return k
+            e <- atomically $ readTChan $ _eventChannel input
+            handleInternalEvent e
         gkey' = do
-            k <- atomically $ tryReadTChan $ _eventChannel input
-            case k of
-                (Just (EvResize _ _))  -> Just <$> mkResize
-                _ -> return k
+            mEv <- atomically $ tryReadTChan $ _eventChannel input
+            case mEv of
+                Just e  -> Just <$> handleInternalEvent e
+                Nothing -> return Nothing
 
     return $ Vty { update = innerUpdate
                  , nextEvent = gkey
diff --git a/src/Graphics/Vty/Input.hs b/src/Graphics/Vty/Input.hs
index a133a55..36c5415 100644
--- a/src/Graphics/Vty/Input.hs
+++ b/src/Graphics/Vty/Input.hs
@@ -158,9 +158,8 @@ inputForConfig config@Config{ termName = Just termName
     setAttrs
     input <- initInput config activeInputMap
     let pokeIO = Catch $ do
-            let e = error "vty internal failure: this value should not propagate to users"
             setAttrs
-            atomically $ writeTChan (input^.eventChannel) (EvResize e e)
+            atomically $ writeTChan (input^.eventChannel) ResumeAfterSignal
     _ <- installHandler windowChange pokeIO Nothing
     _ <- installHandler continueProcess pokeIO Nothing
 
diff --git a/src/Graphics/Vty/Input/Events.hs b/src/Graphics/Vty/Input/Events.hs
index bc0006d..3db245b 100644
--- a/src/Graphics/Vty/Input/Events.hs
+++ b/src/Graphics/Vty/Input/Events.hs
@@ -76,3 +76,13 @@ data Event
 instance NFData Event
 
 type ClassifyMap = [(String,Event)]
+
+-- | The type of internal events that drive the internal Vty event
+-- dispatching to the application.
+data InternalEvent =
+    ResumeAfterSignal
+    -- ^ Vty resumed operation after the process was interrupted with a
+    -- signal. In practice this translates into a screen redraw in the
+    -- input event loop.
+    | InputEvent Event
+    -- ^ An input event was received.
diff --git a/src/Graphics/Vty/Input/Loop.hs b/src/Graphics/Vty/Input/Loop.hs
index 9c128a3..a992bae 100644
--- a/src/Graphics/Vty/Input/Loop.hs
+++ b/src/Graphics/Vty/Input/Loop.hs
@@ -55,7 +55,7 @@ data Input = Input
     { -- | Channel of events direct from input processing. Unlike
       -- 'nextEvent' this will not refresh the display if the next event
       -- is an 'EvResize'.
-      _eventChannel  :: TChan Event
+      _eventChannel  :: TChan InternalEvent
       -- | Shuts down the input processing. As part of shutting down the
       -- input, this should also restore the input state.
     , shutdownInput :: IO ()
@@ -115,7 +115,7 @@ addBytesToProcess block = unprocessedBytes <>= block
 emit :: Event -> InputM ()
 emit event = do
     logMsg $ "parsed event: " ++ show event
-    view eventChannel >>= liftIO . atomically . flip writeTChan event
+    view eventChannel >>= liftIO . atomically . flip writeTChan (InputEvent event)
 
 -- The timing requirements are assured by the VMIN and VTIME set for the
 -- device.