From c5126411571e20dd3753ab63da358fb3702fead5 Mon Sep 17 00:00:00 2001
From: Daniel Goertzen <daniel.goertzen@gmail.com>
Date: Thu, 11 Mar 2021 14:26:25 -0600
Subject: [PATCH] Add `useTermHandles` behavior for explicitly providing term
 handles and term type

---
 System/Console/Haskeline.hs                  |  3 +++
 System/Console/Haskeline/Backend.hs          | 22 +++++++++++++++-----
 System/Console/Haskeline/Backend/Posix.hsc   | 10 +++++++++
 System/Console/Haskeline/Backend/Terminfo.hs |  6 +++---
 System/Console/Haskeline/InputT.hs           | 10 +++++++++
 5 files changed, 43 insertions(+), 8 deletions(-)

diff --git a/System/Console/Haskeline.hs b/System/Console/Haskeline.hs
index f42277bc..4cb89755 100644
--- a/System/Console/Haskeline.hs
+++ b/System/Console/Haskeline.hs
@@ -39,6 +39,9 @@ module System.Console.Haskeline(
                     defaultBehavior,
                     useFileHandle,
                     useFile,
+#ifndef MINGW
+                    useTermHandles,
+#endif
                     preferTerm,
                     -- * User interaction functions
                     -- ** Reading user input
diff --git a/System/Console/Haskeline/Backend.hs b/System/Console/Haskeline/Backend.hs
index 66fb39f7..06ba7298 100644
--- a/System/Console/Haskeline/Backend.hs
+++ b/System/Console/Haskeline/Backend.hs
@@ -23,27 +23,39 @@ defaultRunTerm = (liftIO (hGetEcho stdin) >>= guard >> stdinTTY)
 terminalRunTerm :: IO RunTerm
 terminalRunTerm = directTTY `orElse` fileHandleRunTerm stdin
 
+#ifndef MINGW
+useTermHandlesRunTerm :: Maybe String -> Handle -> Handle -> IO RunTerm
+useTermHandlesRunTerm termtype input output =
+    explicitTTY termtype input output `orElse` fileHandleRunTerm input
+#endif
+
 stdinTTY :: MaybeT IO RunTerm
 #ifdef MINGW
 stdinTTY = win32TermStdin
 #else
-stdinTTY = stdinTTYHandles >>= runDraw
+stdinTTY = stdinTTYHandles >>= runDraw Nothing
 #endif
 
 directTTY :: MaybeT IO RunTerm
 #ifdef MINGW
 directTTY = win32Term
 #else
-directTTY = ttyHandles >>= runDraw
+directTTY = ttyHandles >>= runDraw Nothing
+#endif
+
+#ifndef MINGW
+explicitTTY :: Maybe String -> Handle -> Handle -> MaybeT IO RunTerm
+explicitTTY termtype input output =
+    explicitTTYHandles input output >>= runDraw termtype
 #endif
 
 
 #ifndef MINGW
-runDraw :: Handles -> MaybeT IO RunTerm
+runDraw :: Maybe String -> Handles -> MaybeT IO RunTerm
 #ifndef TERMINFO
-runDraw = runDumbTerm
+runDraw _termtype = runDumbTerm
 #else
-runDraw h = runTerminfoDraw h `mplus` runDumbTerm h
+runDraw termtype h = runTerminfoDraw termtype h `mplus` runDumbTerm h
 #endif
 #endif
 
diff --git a/System/Console/Haskeline/Backend/Posix.hsc b/System/Console/Haskeline/Backend/Posix.hsc
index da8c96c2..6aa9edec 100644
--- a/System/Console/Haskeline/Backend/Posix.hsc
+++ b/System/Console/Haskeline/Backend/Posix.hsc
@@ -11,6 +11,7 @@ module System.Console.Haskeline.Backend.Posix (
                         mapLines,
                         stdinTTYHandles,
                         ttyHandles,
+                        explicitTTYHandles,
                         posixRunTerm,
                         fileRunTerm
                  ) where
@@ -286,6 +287,15 @@ openTerm :: IOMode -> MaybeT IO ExternalHandle
 openTerm mode = handle (\(_::IOException) -> mzero)
             $ liftIO $ openInCodingMode "/dev/tty" mode
 
+explicitTTYHandles :: Handle -> Handle -> MaybeT IO Handles
+explicitTTYHandles h_in h_out = do
+    isInTerm <- liftIO $ hIsTerminalDevice h_in
+    guard isInTerm
+    return Handles
+            { hIn = externalHandle h_in
+            , hOut = externalHandle h_out
+            , closeHandles = return ()
+            }
 
 posixRunTerm ::
     Handles
diff --git a/System/Console/Haskeline/Backend/Terminfo.hs b/System/Console/Haskeline/Backend/Terminfo.hs
index 7be700fa..769db21e 100644
--- a/System/Console/Haskeline/Backend/Terminfo.hs
+++ b/System/Console/Haskeline/Backend/Terminfo.hs
@@ -125,9 +125,9 @@ evalDraw term actions = EvalTerm eval liftE
                             . unDraw 
  
 
-runTerminfoDraw :: Handles -> MaybeT IO RunTerm
-runTerminfoDraw h = do
-    mterm <- liftIO $ Exception.try setupTermFromEnv
+runTerminfoDraw :: Maybe String -> Handles -> MaybeT IO RunTerm
+runTerminfoDraw termtype h = do
+    mterm <- liftIO $ Exception.try $ maybe setupTermFromEnv setupTerm termtype
     case mterm of
         Left (_::SetupTermError) -> mzero
         Right term -> do
diff --git a/System/Console/Haskeline/InputT.hs b/System/Console/Haskeline/InputT.hs
index d8849b96..4b161d57 100644
--- a/System/Console/Haskeline/InputT.hs
+++ b/System/Console/Haskeline/InputT.hs
@@ -216,6 +216,16 @@ useFile file = Behavior $ do
 preferTerm :: Behavior
 preferTerm = Behavior terminalRunTerm
 
+#ifndef MINGW
+-- | Use terminal-style interaction on the given input and output handles.  The terminal
+-- type may also be explicitly specified.
+--
+-- This behavior is for dealing with terminals other than the controlling terminal.
+-- The caller is responsible for closing handles after use.  Not available on Windows.
+useTermHandles :: Maybe String -> Handle -> Handle -> Behavior
+useTermHandles termtype input output =
+    Behavior $ useTermHandlesRunTerm termtype input output
+#endif
 
 -- | Read 'Prefs' from @~/.haskeline.@   If there is an error reading the file,
 -- the 'defaultPrefs' will be returned.