From 350b1d8893297ffbfdbec0991ad1a5768e161eb4 Mon Sep 17 00:00:00 2001
From: Daniel Goertzen <daniel.goertzen@gmail.com>
Date: Thu, 27 May 2021 10:31:17 -0500
Subject: [PATCH] add timeout for getBlockOfChars

- fixes issue #160 and maybe issue #77.
- 20ms delay worked well for 9600bps serial port, 10ms did not.
---
 System/Console/Haskeline/Backend/Posix.hsc | 39 +++++++++++++++-------
 haskeline.cabal                            |  2 +-
 2 files changed, 28 insertions(+), 13 deletions(-)

diff --git a/System/Console/Haskeline/Backend/Posix.hsc b/System/Console/Haskeline/Backend/Posix.hsc
index da8c96c..666a5ef 100644
--- a/System/Console/Haskeline/Backend/Posix.hsc
+++ b/System/Console/Haskeline/Backend/Posix.hsc
@@ -24,6 +24,9 @@ import Control.Monad
 import Control.Monad.Catch (MonadMask, handle, finally)
 import Control.Concurrent.STM
 import Control.Concurrent hiding (throwTo)
+import Control.Concurrent.Async (runConcurrently, Concurrently(..))
+import Control.Applicative ((<|>))
+import Data.Functor (($>))
 import Data.Maybe (catMaybes)
 import System.Posix.Signals.Exts
 import System.Posix.Types(Fd(..))
@@ -243,21 +246,33 @@ getEvent h baseMap = keyEventLoop $ do
         return [KeyInput $ lexKeys baseMap cs]
 
 -- Read at least one character of input, and more if immediately
--- available.  In particular the characters making up a control sequence
--- will all be available at once, so they can be processed together
--- (with Posix.lexKeys).
+-- available.  If an ESC character is seen, timeout mode is
+-- activated to prevent control sequences from being broken across
+-- getBlockofChars calls.  A timeout of 20ms was shown to work
+-- well with a 9600bps serial port.
 getBlockOfChars :: Handle -> IO String
 getBlockOfChars h = do
     c <- hGetChar h
-    loop [c]
-  where
-    loop cs = do
-        isReady <- hReady h
-        if not isReady
-            then return $ reverse cs
-            else do
-                    c <- hGetChar h
-                    loop (c:cs)
+    loop c [] False
+    where
+    loop :: Char -> String -> Bool -> IO String
+    loop c' cs' timeout' = do
+        let
+            timeout = timeout' || (c' == '\ESC')
+            cs = (c':cs')
+        maybeC <- do
+            isReady <- hReady h
+            case (timeout, isReady) of
+                (_, True) -> do -- fast new character case
+                    Just <$> hGetChar h
+                (True, False) -> -- wait up to 20ms for next char
+                    runConcurrently $ Concurrently (Just <$> hGetChar h)
+                                  <|> Concurrently (threadDelay 20000 $> Nothing)
+                (False, False) -> -- no new char and timeout mode has not been triggered
+                    pure Nothing
+        case maybeC of
+            Just c -> loop c cs timeout
+            Nothing -> pure $ reverse cs
 
 stdinTTYHandles, ttyHandles :: MaybeT IO Handles
 stdinTTYHandles = do
diff --git a/haskeline.cabal b/haskeline.cabal
index 7b8d8d0..ccf27d5 100644
--- a/haskeline.cabal
+++ b/haskeline.cabal
@@ -53,7 +53,7 @@ Library
                    directory>=1.1 && < 1.4, bytestring>=0.9 && < 0.12,
                    filepath >= 1.2 && < 1.5, transformers >= 0.2 && < 0.7,
                    process >= 1.0 && < 1.7, stm >= 2.4 && < 2.6,
-                   exceptions == 0.10.*
+                   exceptions == 0.10.*, async == 2.2.*
     Default-Language: Haskell98
     Default-Extensions:
                 ForeignFunctionInterface, Rank2Types, FlexibleInstances,