aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Ghci.hs20
1 files 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