Example for controlling ghci interactively with conduit's process module

ProcessConduitGhciExample.hs

-- 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
    --     https://github.com/snoyberg/conduit/issues/402
    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
          runConduit
            $ (let loop = do
                     mbCommand <- liftIO $ takeMVar commandMVar
                     case mbCommand of
                       Nothing -> return ()
                       Just command -> do
                        yield (T.encodeUtf8 command <> "\n")
                        loop
               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
          runConduit
             $ 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