{-# LANGUAGE RecordWildCards #-}

-- | Library for spawning and working with Ghci sessions.
module Language.Haskell.Ghcid(
    Ghci, GhciError(..), Stream(..),
    Load(..), Severity(..),
    startGhci, startGhciProcess, stopGhci, interrupt, process,
    execStream, showModules, showPaths, reload, exec, quit
    ) where

import System.IO
import System.IO.Error
import System.Process
import System.Time.Extra
import Control.Concurrent.Extra
import Control.Exception.Extra
import Control.Monad.Extra
import Data.Function
import Data.List.Extra
import Data.Maybe
import Data.IORef
import Control.Applicative
import Data.Unique

import System.Console.CmdArgs.Verbosity

import Language.Haskell.Ghcid.Parser
import Language.Haskell.Ghcid.Types as T
import Language.Haskell.Ghcid.Util
import Prelude


-- | A GHCi session. Created with 'startGhci', closed with 'stopGhci'.
--
--   The interactions with a 'Ghci' session must all occur single-threaded,
--   or an error will be raised. The only exception is 'interrupt', which aborts
--   a running computation, or does nothing if no computation is running.
data Ghci = Ghci
    {Ghci -> ProcessHandle
ghciProcess :: ProcessHandle
    ,Ghci -> IO ()
ghciInterrupt :: IO ()
    ,Ghci -> String -> (Stream -> String -> IO ()) -> IO ()
ghciExec :: String -> (Stream -> String -> IO ()) -> IO ()
    ,Ghci -> Unique
ghciUnique :: Unique
    }

instance Eq Ghci where
    Ghci
a == :: Ghci -> Ghci -> Bool
== Ghci
b = Ghci -> Unique
ghciUnique Ghci
a Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Ghci -> Unique
ghciUnique Ghci
b


withCreateProc :: CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO c)
-> IO c
withCreateProc CreateProcess
proc Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO c
f = do
    let undo :: (a, b, c, ProcessHandle) -> IO ()
undo (a
_, b
_, c
_, ProcessHandle
proc) = IO () -> IO ()
ignored (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ()
terminateProcess ProcessHandle
proc
    IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO c)
-> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
proc) (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
forall {a} {b} {c}. (a, b, c, ProcessHandle) -> IO ()
undo (((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
  -> IO c)
 -> IO c)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO c)
-> IO c
forall a b. (a -> b) -> a -> b
$ \(Maybe Handle
a,Maybe Handle
b,Maybe Handle
c,ProcessHandle
d) -> Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO c
f Maybe Handle
a Maybe Handle
b Maybe Handle
c ProcessHandle
d

-- | Start GHCi by running the described process, returning  the result of the initial loading.
--   If you do not call 'stopGhci' then the underlying process may be leaked.
--   The callback will be given the messages produced while loading, useful if invoking something like "cabal repl"
--   which might compile dependent packages before really loading.
--
--   To create a 'CreateProcess' use the functions in "System.Process", particularly
--   'System.Process.shell' and 'System.Process.proc'.
--
--   @since 0.6.11
startGhciProcess :: CreateProcess -> (Stream -> String -> IO ()) -> IO (Ghci, [Load])
startGhciProcess :: CreateProcess -> (Stream -> String -> IO ()) -> IO (Ghci, [Load])
startGhciProcess CreateProcess
process Stream -> String -> IO ()
echo0 = do
    let proc :: CreateProcess
proc = CreateProcess
process{std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe, create_group=True}
    CreateProcess
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (Ghci, [Load]))
-> IO (Ghci, [Load])
forall {c}.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO c)
-> IO c
withCreateProc CreateProcess
proc ((Maybe Handle
  -> Maybe Handle
  -> Maybe Handle
  -> ProcessHandle
  -> IO (Ghci, [Load]))
 -> IO (Ghci, [Load]))
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (Ghci, [Load]))
-> IO (Ghci, [Load])
forall a b. (a -> b) -> a -> b
$ \(Just Handle
inp) (Just Handle
out) (Just Handle
err) ProcessHandle
ghciProcess -> do

        Handle -> BufferMode -> IO ()
hSetBuffering Handle
out BufferMode
LineBuffering
        Handle -> BufferMode -> IO ()
hSetBuffering Handle
err BufferMode
LineBuffering
        Handle -> BufferMode -> IO ()
hSetBuffering Handle
inp BufferMode
LineBuffering
        let writeInp :: String -> IO ()
writeInp String
x = do
                IO () -> IO ()
whenLoud (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
outStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"%STDIN: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x
                Handle -> String -> IO ()
hPutStrLn Handle
inp String
x

        -- Some programs (e.g. stack) might use stdin before starting ghci (see #57)
        -- Send them an empty line
        Handle -> String -> IO ()
hPutStrLn Handle
inp String
""

        -- We don't use the GHCi prompt, so set it to a special string and filter that out.
        -- It could be removed as per https://github.com/ndmitchell/ghcid/issues/333
        let ghcid_prefix :: String
ghcid_prefix = String
"#~GHCID-START~#"
        let removePrefix :: String -> String
removePrefix = String -> String -> String
forall a. Eq a => [a] -> [a] -> [a]
dropPrefixRepeatedly String
ghcid_prefix

        -- At various points I need to ensure everything the user is waiting for has completed
        -- So I send messages on stdout/stderr and wait for them to arrive
        syncCount <- Integer -> IO (Var Integer)
forall a. a -> IO (Var a)
newVar Integer
0
        let syncReplay = do
                i <- Var Integer -> IO Integer
forall a. Var a -> IO a
readVar Var Integer
syncCount
                -- useful to avoid overloaded strings by showing the ['a','b','c'] form, see #109
                let showStr [a]
xs = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show [a]
xs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
                let msg = String
"#~GHCID-FINISH-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"~#"
                -- Prepend a leading \n to try and avoid junk already on stdout,
                -- e.g. https://github.com/ndmitchell/ghcid/issues/291
                writeInp $ "\nINTERNAL_GHCID.putStrLn " ++ showStr msg ++ "\n" ++
                           "INTERNAL_GHCID.hPutStrLn INTERNAL_GHCID.stderr " ++ showStr msg
                pure $ isInfixOf msg
        let syncFresh = do
                Var Integer -> (Integer -> IO Integer) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var Integer
syncCount ((Integer -> IO Integer) -> IO ())
-> (Integer -> IO Integer) -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> IO Integer
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> IO Integer)
-> (Integer -> Integer) -> Integer -> IO Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
forall a. Enum a => a -> a
succ
                IO (String -> Bool)
syncReplay

        -- Consume from a stream until EOF (pure Nothing) or some predicate returns Just
        let consume :: Stream -> (String -> IO (Maybe a)) -> IO (Either (Maybe String) a)
            consume Stream
name String -> IO (Maybe a)
finish = do
                let h :: Handle
h = if Stream
name Stream -> Stream -> Bool
forall a. Eq a => a -> a -> Bool
== Stream
Stdout then Handle
out else Handle
err
                (((Maybe String -> IO (Either (Maybe String) a))
  -> Maybe String -> IO (Either (Maybe String) a))
 -> Maybe String -> IO (Either (Maybe String) a))
-> Maybe String
-> ((Maybe String -> IO (Either (Maybe String) a))
    -> Maybe String -> IO (Either (Maybe String) a))
-> IO (Either (Maybe String) a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Maybe String -> IO (Either (Maybe String) a))
 -> Maybe String -> IO (Either (Maybe String) a))
-> Maybe String -> IO (Either (Maybe String) a)
forall a. (a -> a) -> a
fix Maybe String
forall a. Maybe a
Nothing (((Maybe String -> IO (Either (Maybe String) a))
  -> Maybe String -> IO (Either (Maybe String) a))
 -> IO (Either (Maybe String) a))
-> ((Maybe String -> IO (Either (Maybe String) a))
    -> Maybe String -> IO (Either (Maybe String) a))
-> IO (Either (Maybe String) a)
forall a b. (a -> b) -> a -> b
$ \Maybe String -> IO (Either (Maybe String) a)
rec Maybe String
oldMsg -> do
                    el <- (IOError -> Bool) -> IO String -> IO (Either IOError String)
forall e a. Exception e => (e -> Bool) -> IO a -> IO (Either e a)
tryBool IOError -> Bool
isEOFError (IO String -> IO (Either IOError String))
-> IO String -> IO (Either IOError String)
forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetLine Handle
h
                    case el of
                        Left IOError
_ -> Either (Maybe String) a -> IO (Either (Maybe String) a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Maybe String) a -> IO (Either (Maybe String) a))
-> Either (Maybe String) a -> IO (Either (Maybe String) a)
forall a b. (a -> b) -> a -> b
$ Maybe String -> Either (Maybe String) a
forall a b. a -> Either a b
Left Maybe String
oldMsg
                        Right String
l -> do
                            IO () -> IO ()
whenLoud (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
outStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"%" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
upper (Stream -> String
forall a. Show a => a -> String
show Stream
name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l
                            let msg :: String
msg = String -> String
removePrefix String
l
                            res <- String -> IO (Maybe a)
finish String
msg
                            case res of
                                Maybe a
Nothing -> Maybe String -> IO (Either (Maybe String) a)
rec (Maybe String -> IO (Either (Maybe String) a))
-> Maybe String -> IO (Either (Maybe String) a)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
msg
                                Just a
a -> Either (Maybe String) a -> IO (Either (Maybe String) a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Maybe String) a -> IO (Either (Maybe String) a))
-> Either (Maybe String) a -> IO (Either (Maybe String) a)
forall a b. (a -> b) -> a -> b
$ a -> Either (Maybe String) a
forall a b. b -> Either a b
Right a
a

        let consume2 :: String -> (Stream -> String -> IO (Maybe a)) -> IO (a,a)
            consume2 String
msg Stream -> String -> IO (Maybe a)
finish = do
                -- fetch the operations in different threads as hGetLine may block
                -- and can't be aborted by async exceptions, see #154
                res1 <- IO (Either (Maybe String) a) -> IO (IO (Either (Maybe String) a))
forall a. IO a -> IO (IO a)
onceFork (IO (Either (Maybe String) a) -> IO (IO (Either (Maybe String) a)))
-> IO (Either (Maybe String) a)
-> IO (IO (Either (Maybe String) a))
forall a b. (a -> b) -> a -> b
$ Stream -> (String -> IO (Maybe a)) -> IO (Either (Maybe String) a)
forall a.
Stream -> (String -> IO (Maybe a)) -> IO (Either (Maybe String) a)
consume Stream
Stdout (Stream -> String -> IO (Maybe a)
finish Stream
Stdout)
                res2 <- onceFork $ consume Stderr (finish Stderr)
                res1 <- res1
                res2 <- res2
                let raise String
msg Maybe String
err = GhciError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (GhciError -> IO a) -> GhciError -> IO a
forall a b. (a -> b) -> a -> b
$ case CreateProcess -> CmdSpec
cmdspec CreateProcess
process of
                        ShellCommand String
cmd -> String -> String -> Maybe String -> GhciError
UnexpectedExit String
cmd String
msg Maybe String
err
                        RawCommand String
exe [String]
args -> String -> String -> Maybe String -> GhciError
UnexpectedExit ([String] -> String
unwords (String
exeString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args)) String
msg Maybe String
err
                case (res1, res2) of
                    (Right a
v1, Right a
v2) -> (a, a) -> IO (a, a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
v1, a
v2)
                    (Either (Maybe String) a
_, Left Maybe String
err) -> String -> Maybe String -> IO (a, a)
forall {a}. String -> Maybe String -> IO a
raise String
msg Maybe String
err
                    (Either (Maybe String) a
_, Right a
_) -> String -> Maybe String -> IO (a, a)
forall {a}. String -> Maybe String -> IO a
raise String
msg Maybe String
forall a. Maybe a
Nothing

        -- held while interrupting, and briefly held when starting an exec
        -- ensures exec values queue up behind an ongoing interrupt and no two interrupts run at once
        isInterrupting <- newLock

        -- is anyone running running an exec statement, ensure only one person talks to ghci at a time
        isRunning <- newLock

        let ghciExec String
command Stream -> String -> IO a
echo = do
                Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
isInterrupting (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                res <- Lock -> IO () -> IO (Maybe ())
forall a. Lock -> IO a -> IO (Maybe a)
withLockTry Lock
isRunning (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
                    String -> IO ()
writeInp String
command
                    stop <- IO (String -> Bool)
syncFresh
                    void $ consume2 command $ \Stream
strm String
s ->
                        if String -> Bool
stop String
s then Maybe () -> IO (Maybe ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe () -> IO (Maybe ())) -> Maybe () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ () -> Maybe ()
forall a. a -> Maybe a
Just () else do Stream -> String -> IO a
echo Stream
strm String
s; Maybe () -> IO (Maybe ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ()
forall a. Maybe a
Nothing
                when (isNothing res) $
                    fail "Ghcid.exec, computation is already running, must be used single-threaded"

        let ghciInterrupt = Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
isInterrupting (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Maybe () -> Bool) -> IO (Maybe ()) -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe () -> Bool
forall a. Maybe a -> Bool
isNothing (IO (Maybe ()) -> IO Bool) -> IO (Maybe ()) -> IO Bool
forall a b. (a -> b) -> a -> b
$ Lock -> IO () -> IO (Maybe ())
forall a. Lock -> IO a -> IO (Maybe a)
withLockTry Lock
isRunning (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    IO () -> IO ()
whenLoud (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
outStrLn String
"%INTERRUPT"
                    ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
ghciProcess
                    -- let the person running ghciExec finish, since their sync messages
                    -- may have been the ones that got interrupted
                    IO (String -> Bool)
syncReplay
                    -- now wait for the person doing ghciExec to have actually left the lock
                    Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
isRunning (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    -- there may have been two syncs sent, so now do a fresh sync to clear everything
                    stop <- IO (String -> Bool)
syncFresh
                    void $ consume2 "Interrupt" $ \Stream
_ String
s -> Maybe () -> IO (Maybe ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe () -> IO (Maybe ())) -> Maybe () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ if String -> Bool
stop String
s then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing

        ghciUnique <- newUnique
        let ghci = Ghci{IO ()
Unique
ProcessHandle
String -> (Stream -> String -> IO ()) -> IO ()
forall {a}. String -> (Stream -> String -> IO a) -> IO ()
ghciProcess :: ProcessHandle
ghciInterrupt :: IO ()
ghciExec :: String -> (Stream -> String -> IO ()) -> IO ()
ghciUnique :: Unique
ghciProcess :: ProcessHandle
ghciExec :: forall {a}. String -> (Stream -> String -> IO a) -> IO ()
ghciInterrupt :: IO ()
ghciUnique :: Unique
..}

        -- Now wait for 'GHCi, version' to appear before sending anything real, required for #57
        stdout <- newIORef []
        stderr <- newIORef []
        sync <- newIORef $ const False
        consume2 "" $ \Stream
strm String
s -> do
            stop <- IORef (String -> Bool) -> IO (String -> Bool)
forall a. IORef a -> IO a
readIORef IORef (String -> Bool)
sync
            if stop s then
                pure $ Just ()
            else do
                -- there may be some initial prompts on stdout before I set the prompt properly
                s <- pure $ maybe s (removePrefix . snd) $ stripInfix ghcid_prefix s
                whenLoud $ outStrLn $ "%STDOUT2: " ++ s
                modifyIORef (if strm == Stdout then stdout else stderr) (s:)
                when (any (`isPrefixOf` s) [ "GHCi, version "
                                           , "GHCJSi, version "
                                           , "Clashi, version " ]) $ do
                    -- the thing before me may have done its own Haskell compiling
                    writeIORef stdout []
                    writeIORef stderr []
                    writeInp "import qualified System.IO as INTERNAL_GHCID"
                    writeInp ":unset +t +s" -- see https://github.com/ndmitchell/ghcid/issues/162
                    writeInp $ ":set prompt " ++ ghcid_prefix
                    writeInp $ ":set prompt-cont " ++ ghcid_prefix

                    -- failure isn't harmful, so do them one-by-one
                    forM_ (ghciFlagsRequired ++ ghciFlagsRequiredVersioned) $ \String
flag ->
                        String -> IO ()
writeInp (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
":set " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
flag
                    writeIORef sync =<< syncFresh
                echo0 strm s
                pure Nothing
        r1 <- parseLoad . reverse <$> ((++) <$> readIORef stderr <*> readIORef stdout)
        -- see #132, if hide-source-paths was turned on the modules didn't get printed out properly
        -- so try a showModules to capture the information again
        r2 <- if any isLoading r1 then pure [] else map (uncurry Loading) <$> showModules ghci
        execStream ghci "" echo0
        pure (ghci, r1 ++ r2)


-- | Start GHCi by running the given shell command, a helper around 'startGhciProcess'.
startGhci
    :: String -- ^ Shell command
    -> Maybe FilePath -- ^ Working directory
    -> (Stream -> String -> IO ()) -- ^ Output callback
    -> IO (Ghci, [Load])
startGhci :: String
-> Maybe String -> (Stream -> String -> IO ()) -> IO (Ghci, [Load])
startGhci String
cmd Maybe String
directory = CreateProcess -> (Stream -> String -> IO ()) -> IO (Ghci, [Load])
startGhciProcess (String -> CreateProcess
shell String
cmd){cwd=directory}


-- | Execute a command, calling a callback on each response.
--   The callback will be called single threaded.
execStream :: Ghci -> String -> (Stream -> String -> IO ()) -> IO ()
execStream :: Ghci -> String -> (Stream -> String -> IO ()) -> IO ()
execStream = Ghci -> String -> (Stream -> String -> IO ()) -> IO ()
ghciExec

-- | Interrupt Ghci, stopping the current computation (if any),
--   but leaving the process open to new input.
interrupt :: Ghci -> IO ()
interrupt :: Ghci -> IO ()
interrupt = Ghci -> IO ()
ghciInterrupt

-- | Obtain the progress handle behind a GHCi instance.
process :: Ghci -> ProcessHandle
process :: Ghci -> ProcessHandle
process = Ghci -> ProcessHandle
ghciProcess


---------------------------------------------------------------------
-- SUGAR HELPERS

-- | Execute a command, calling a callback on each response.
--   The callback will be called single threaded.
execBuffer :: Ghci -> String -> (Stream -> String -> IO ()) -> IO [String]
execBuffer :: Ghci -> String -> (Stream -> String -> IO ()) -> IO [String]
execBuffer Ghci
ghci String
cmd Stream -> String -> IO ()
echo = do
    stdout <- [String] -> IO (IORef [String])
forall a. a -> IO (IORef a)
newIORef []
    stderr <- newIORef []
    execStream ghci cmd $ \Stream
strm String
s -> do
        IORef [String] -> ([String] -> [String]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (if Stream
strm Stream -> Stream -> Bool
forall a. Eq a => a -> a -> Bool
== Stream
Stdout then IORef [String]
stdout else IORef [String]
stderr) (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:)
        Stream -> String -> IO ()
echo Stream
strm String
s
    reverse <$> ((++) <$> readIORef stderr <*> readIORef stdout)

-- | Send a command, get lines of result. Must be called single-threaded.
exec :: Ghci -> String -> IO [String]
exec :: Ghci -> String -> IO [String]
exec Ghci
ghci String
cmd = Ghci -> String -> (Stream -> String -> IO ()) -> IO [String]
execBuffer Ghci
ghci String
cmd ((Stream -> String -> IO ()) -> IO [String])
-> (Stream -> String -> IO ()) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \Stream
_ String
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | List the modules currently loaded, with module name and source file.
showModules :: Ghci -> IO [(String,FilePath)]
showModules :: Ghci -> IO [(String, String)]
showModules Ghci
ghci = [String] -> [(String, String)]
parseShowModules ([String] -> [(String, String)])
-> IO [String] -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ghci -> String -> IO [String]
exec Ghci
ghci String
":show modules"

-- | Return the current working directory, and a list of module import paths
showPaths :: Ghci -> IO (FilePath, [FilePath])
showPaths :: Ghci -> IO (String, [String])
showPaths Ghci
ghci = [String] -> (String, [String])
parseShowPaths ([String] -> (String, [String]))
-> IO [String] -> IO (String, [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ghci -> String -> IO [String]
exec Ghci
ghci String
":show paths"

-- | Perform a reload, list the messages that reload generated.
reload :: Ghci -> IO [Load]
reload :: Ghci -> IO [Load]
reload Ghci
ghci = [String] -> [Load]
parseLoad ([String] -> [Load]) -> IO [String] -> IO [Load]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ghci -> String -> IO [String]
exec Ghci
ghci String
":reload"

-- | Send @:quit@ and wait for the process to quit.
quit :: Ghci -> IO ()
quit :: Ghci -> IO ()
quit Ghci
ghci =  do
    Ghci -> IO ()
interrupt Ghci
ghci
    (GhciError -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\UnexpectedExit{} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO [String] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [String] -> IO ()) -> IO [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ Ghci -> String -> IO [String]
exec Ghci
ghci String
":quit"
    -- Be aware that waitForProcess has a race condition, see https://github.com/haskell/process/issues/46.
    -- Therefore just ignore the exception anyway, its probably already terminated.
    IO () -> IO ()
ignored (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
waitForProcess (ProcessHandle -> IO ExitCode) -> ProcessHandle -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ Ghci -> ProcessHandle
process Ghci
ghci


-- | Stop GHCi. Attempts to interrupt and execute @:quit:@, but if that doesn't complete
--   within 5 seconds it just terminates the process.
stopGhci :: Ghci -> IO ()
stopGhci :: Ghci -> IO ()
stopGhci Ghci
ghci = do
    IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        -- if nicely doesn't work, kill ghci as the process level
        Seconds -> IO ()
sleep Seconds
5
        ProcessHandle -> IO ()
terminateProcess (ProcessHandle -> IO ()) -> ProcessHandle -> IO ()
forall a b. (a -> b) -> a -> b
$ Ghci -> ProcessHandle
process Ghci
ghci
    Ghci -> IO ()
quit Ghci
ghci