Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
Example for controlling ghci interactively with conduit's process module
-- Example for controlling ghci interactively with conduit's process module.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Conduit
import Control.Concurrent.Async
import Control.Concurrent.MVar
import Control.Monad
import Data.Conduit (runConduit, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.Process.Typed (proc, setStdin, setStdout, createPipe, createSource, getStdin, getStdout, withProcess)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import Data.Text (Text)
import System.IO (hSetBuffering, BufferMode(NoBuffering))
import qualified Data.ByteString as BS
say :: Text -> IO ()
say = BS.putStr . T.encodeUtf8 . (<> "\n")
main :: IO ()
main = do
-- Prepare file to load
BS.writeFile "test.hs" "main = return ()"
let cp = setStdin createPipe $ setStdout createSource $ proc "ghci" ["test.hs"]
withProcess cp $ \p -> do
-- Set buffering of child process to NoBuffering, otherwise
-- our short commands (like `:reload`) will not be sent to the
-- child process at all, see
hSetBuffering (getStdin p) NoBuffering
modulesLoadedMVar :: MVar () <- newEmptyMVar
commandMVar :: MVar (Maybe Text) <- newEmptyMVar
-- Thread that feeds commands dropped into `commandMVar` to ghci.
let provideGhciInput :: IO ()
provideGhciInput = do
$ (let loop = do
mbCommand <- liftIO $ takeMVar commandMVar
case mbCommand of
Nothing -> return ()
Just command -> do
yield (T.encodeUtf8 command <> "\n")
in loop)
.| CB.sinkHandle (getStdin p)
-- Thread that reads ghci output, places the lines in `ghciOutputRef`
-- and fills `modulesLoadedMVar` with `()` when "modules loaded" appears in
-- the output.
let processGhciOutput :: IO ()
processGhciOutput = do
$ getStdout p
.| CB.lines
.| CL.mapM_ (\lineBS -> do
let line = T.decodeUtf8 lineBS -- let it crash if not
say $ "+ " <> line
-- Ghci prints either e.g.
-- Failed, 154 modules loaded.
-- or
-- Ok, 163 modules loaded.
let loaded =
"module loaded." `T.isInfixOf` line
"modules loaded." `T.isInfixOf` line
when loaded $ do
when (not ("ok" `T.isInfixOf` T.toLower line)) $ do
error $ "ghci loaded line does not contain an 'ok': " ++ T.unpack line
putMVar modulesLoadedMVar ()
let controller :: IO ()
controller = do
-- Initial `Setup.hs repl` startup.
say $ "Waiting for initial module load"
takeMVar modulesLoadedMVar
say $ "Initial module load done"
say $ "Issuing :reload"
putMVar commandMVar (Just ":reload")
takeMVar modulesLoadedMVar -- wait until loaded
say $ "Issuing :quit"
putMVar commandMVar (Just ":quit")
putMVar commandMVar Nothing -- signal input thread to stop
runConcurrently $
Concurrently provideGhciInput *>
Concurrently processGhciOutput *>
Concurrently controller
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.