From c269a0b1d3fb2e277cf6afa2833cb39524c1b45d Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Mon, 27 Jun 2022 21:59:18 +0200
Subject: Allow debug prints for ghci interaction (when statically enabled)

---
 src/Ghci.hs | 20 +++++++++++++++-----
 1 file changed, 15 insertions(+), 5 deletions(-)

diff --git a/src/Ghci.hs b/src/Ghci.hs
index 47777f2..d8410b7 100644
--- a/src/Ghci.hs
+++ b/src/Ghci.hs
@@ -23,7 +23,7 @@ import qualified Data.ByteString.Short as BSS
 import Data.Char (isSpace, toLower)
 import Data.List (nub)
 import Foreign (allocaBytes)
-import System.IO (hFlush, hIsClosed, hGetBufSome, hPutStrLn, Handle)
+import System.IO (hFlush, hIsClosed, hGetBufSome, hPutStrLn, stderr, Handle)
 import System.Process
 import System.Random (getStdRandom, uniformR)
 import System.Timeout (timeout)
@@ -31,6 +31,15 @@ import System.Timeout (timeout)
 import ExitEarly
 
 
+debugPrints :: Bool
+debugPrints = False
+
+ghciPutStrLn :: Handle -> String -> IO ()
+ghciPutStrLn h s = do
+  when debugPrints $ hPutStrLn stderr ("Writing: <" ++ s ++ ">")
+  hPutStrLn h s
+
+
 data Ghci = Ghci
   { ghciProc :: ProcessHandle
   , ghciStdin :: Handle
@@ -49,8 +58,8 @@ makeGhci = do
       , std_in = CreatePipe
       , std_out = UseHandle pipeIn
       , std_err = UseHandle pipeIn }
-  hPutStrLn stdinH ":set -interactive-print=Yahb2Defs.limitedPrint"
-  hPutStrLn stdinH ":m"
+  ghciPutStrLn stdinH ":set -interactive-print=Yahb2Defs.limitedPrint"
+  ghciPutStrLn stdinH ":m"
   hFlush stdinH
   return Ghci { ghciProc = proch
               , ghciStdin = stdinH
@@ -115,7 +124,7 @@ terminateGhci ghci = terminateProcess (ghciProc ghci)
 runStmt' :: Ghci -> String -> IO String
 runStmt' ghci stmt = do
   tag <- updatePrompt ghci
-  hPutStrLn (ghciStdin ghci) stmt
+  ghciPutStrLn (ghciStdin ghci) stmt
   hFlush (ghciStdin ghci)
   (output, reason) <- hGetUntilUTF8 (ghciStdout ghci) (Just 8192) tag
   case reason of
@@ -138,7 +147,7 @@ updatePrompt :: Ghci -> IO String
 updatePrompt ghci = do
   tag <- genTag
   -- putStrLn ("chose prompt: " ++ tag)
-  hPutStrLn (ghciStdin ghci) (":set prompt " ++ tag)
+  ghciPutStrLn (ghciStdin ghci) (":set prompt " ++ tag)
   hFlush (ghciStdin ghci)
   -- putStrLn ("set prompt " ++ tag)
   _ <- hGetUntilUTF8 (ghciStdout ghci) (Just 8192) tag
@@ -189,4 +198,5 @@ hGetUntil h mmax tag = do
           -- lift $ putStrLn ("nextPrefixes = " ++ show nextPrefixes)
           loop (yet + nread) nextPrefixes (builder <> BSB.byteString bs)
     result <- execExitEarlyT (loop 0 [] mempty)
+    when debugPrints $ hPutStrLn stderr ("Read: <" ++ show result ++ ">")
     return $! result
-- 
cgit v1.2.3-70-g09d2