diff options
| -rw-r--r-- | src/Ghci.hs | 20 |
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 |