{-# 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 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 forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ()
terminateProcess ProcessHandle
proc
    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) forall {a} {b} {c}. (a, b, c, ProcessHandle) -> IO ()
undo 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 :: StdStream
std_in=StdStream
CreatePipe, std_out :: StdStream
std_out=StdStream
CreatePipe, std_err :: StdStream
std_err=StdStream
CreatePipe, create_group :: Bool
create_group=Bool
True}
    forall {c}.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO c)
-> IO c
withCreateProc CreateProcess
proc 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 forall a b. (a -> b) -> a -> b
$ String -> IO ()
outStrLn forall a b. (a -> b) -> a -> b
$ String
"%STDIN: " 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 = 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
        Var Integer
syncCount <- forall a. a -> IO (Var a)
newVar Integer
0
        let syncReplay :: IO (String -> Bool)
syncReplay = do
                Integer
i <- 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] -> String
showStr [a]
xs = String
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [a]
xs) forall a. [a] -> [a] -> [a]
++ String
"]"
                let msg :: String
msg = String
"#~GHCID-FINISH-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
i 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
                String -> IO ()
writeInp forall a b. (a -> b) -> a -> b
$ String
"\nINTERNAL_GHCID.putStrLn " forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => [a] -> String
showStr String
msg forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
                           String
"INTERNAL_GHCID.hPutStrLn INTERNAL_GHCID.stderr " forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => [a] -> String
showStr String
msg
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> Bool
isInfixOf String
msg
        let syncFresh :: IO (String -> Bool)
syncFresh = do
                forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var Integer
syncCount forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a.
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 forall a. Eq a => a -> a -> Bool
== Stream
Stdout then Handle
out else Handle
err
                forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> a) -> a
fix forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ \Maybe String -> IO (Either (Maybe String) a)
rec Maybe String
oldMsg -> do
                    Either IOError String
el <- forall e a. Exception e => (e -> Bool) -> IO a -> IO (Either e a)
tryBool IOError -> Bool
isEOFError forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetLine Handle
h
                    case Either IOError String
el of
                        Left IOError
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Maybe String
oldMsg
                        Right String
l -> do
                            IO () -> IO ()
whenLoud forall a b. (a -> b) -> a -> b
$ String -> IO ()
outStrLn forall a b. (a -> b) -> a -> b
$ String
"%" forall a. [a] -> [a] -> [a]
++ String -> String
upper (forall a. Show a => a -> String
show Stream
name) forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
l
                            let msg :: String
msg = String -> String
removePrefix String
l
                            Maybe a
res <- String -> IO (Maybe a)
finish String
msg
                            case Maybe a
res of
                                Maybe a
Nothing -> Maybe String -> IO (Either (Maybe String) a)
rec forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just String
msg
                                Just a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
a

        let consume2 :: String -> (Stream -> String -> IO (Maybe a)) -> IO (a,a)
            consume2 :: forall a. 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
                IO (Either (Maybe String) a)
res1 <- forall a. IO a -> IO (IO a)
onceFork forall a b. (a -> b) -> a -> b
$ forall a.
Stream -> (String -> IO (Maybe a)) -> IO (Either (Maybe String) a)
consume Stream
Stdout (Stream -> String -> IO (Maybe a)
finish Stream
Stdout)
                IO (Either (Maybe String) a)
res2 <- forall a. IO a -> IO (IO a)
onceFork forall a b. (a -> b) -> a -> b
$ forall a.
Stream -> (String -> IO (Maybe a)) -> IO (Either (Maybe String) a)
consume Stream
Stderr (Stream -> String -> IO (Maybe a)
finish Stream
Stderr)
                Either (Maybe String) a
res1 <- IO (Either (Maybe String) a)
res1
                Either (Maybe String) a
res2 <- IO (Either (Maybe String) a)
res2
                let raise :: String -> Maybe String -> IO a
raise String
msg Maybe String
err = forall e a. Exception e => e -> IO a
throwIO 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
exeforall a. a -> [a] -> [a]
:[String]
args)) String
msg Maybe String
err
                case (Either (Maybe String) a
res1, Either (Maybe String) a
res2) of
                    (Right a
v1, Right a
v2) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
v1, a
v2)
                    (Either (Maybe String) a
_, Left Maybe String
err) -> forall {a}. String -> Maybe String -> IO a
raise String
msg Maybe String
err
                    (Either (Maybe String) a
_, Right a
_) -> forall {a}. String -> Maybe String -> IO a
raise String
msg 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
        Lock
isInterrupting <- IO Lock
newLock

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

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

        let ghciInterrupt :: IO ()
ghciInterrupt = forall a. Lock -> IO a -> IO a
withLock Lock
isInterrupting forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ forall a. Lock -> IO a -> IO (Maybe a)
withLockTry Lock
isRunning forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a b. (a -> b) -> a -> b
$ do
                    IO () -> IO ()
whenLoud 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
                    forall a. Lock -> IO a -> IO a
withLock Lock
isRunning forall a b. (a -> b) -> a -> b
$ 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
                    String -> Bool
stop <- IO (String -> Bool)
syncFresh
                    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. String -> (Stream -> String -> IO (Maybe a)) -> IO (a, a)
consume2 String
"Interrupt" forall a b. (a -> b) -> a -> b
$ \Stream
_ String
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if String -> Bool
stop String
s then forall a. a -> Maybe a
Just () else forall a. Maybe a
Nothing

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

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

                    -- failure isn't harmful, so do them one-by-one
                    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([String]
ghciFlagsRequired forall a. [a] -> [a] -> [a]
++ [String]
ghciFlagsRequiredVersioned) forall a b. (a -> b) -> a -> b
$ \String
flag ->
                        String -> IO ()
writeInp forall a b. (a -> b) -> a -> b
$ String
":set " forall a. [a] -> [a] -> [a]
++ String
flag
                    forall a. IORef a -> a -> IO ()
writeIORef IORef (String -> Bool)
sync forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (String -> Bool)
syncFresh
                Stream -> String -> IO ()
echo0 Stream
strm String
s
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        [Load]
r1 <- [String] -> [Load]
parseLoad forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef [String]
stderr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. IORef a -> IO a
readIORef IORef [String]
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
        [Load]
r2 <- if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Load -> Bool
isLoading [Load]
r1 then forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> Load
Loading) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ghci -> IO [(String, String)]
showModules Ghci
ghci
        Ghci -> String -> (Stream -> String -> IO ()) -> IO ()
execStream Ghci
ghci String
"" Stream -> String -> IO ()
echo0
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ghci
ghci, [Load]
r1 forall a. [a] -> [a] -> [a]
++ [Load]
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 :: Maybe String
cwd=Maybe String
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
    IORef [String]
stdout <- forall a. a -> IO (IORef a)
newIORef []
    IORef [String]
stderr <- forall a. a -> IO (IORef a)
newIORef []
    Ghci -> String -> (Stream -> String -> IO ()) -> IO ()
execStream Ghci
ghci String
cmd forall a b. (a -> b) -> a -> b
$ \Stream
strm String
s -> do
        forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (if Stream
strm forall a. Eq a => a -> a -> Bool
== Stream
Stdout then IORef [String]
stdout else IORef [String]
stderr) (String
sforall a. a -> [a] -> [a]
:)
        Stream -> String -> IO ()
echo Stream
strm String
s
    forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef [String]
stderr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. IORef a -> IO a
readIORef IORef [String]
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 forall a b. (a -> b) -> a -> b
$ \Stream
_ String
_ -> 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 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 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 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
    forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\UnexpectedExit{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void 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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
waitForProcess 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 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 forall a b. (a -> b) -> a -> b
$ Ghci -> ProcessHandle
process Ghci
ghci
    Ghci -> IO ()
quit Ghci
ghci