{-# LANGUAGE RecordWildCards #-}
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
data Ghci = Ghci
{ghciProcess :: ProcessHandle
,ghciInterrupt :: IO ()
,ghciExec :: String -> (Stream -> String -> IO ()) -> IO ()
,ghciUnique :: Unique
}
instance Eq Ghci where
a == b = ghciUnique a == ghciUnique b
withCreateProc proc f = do
let undo (_, _, _, proc) = ignored $ terminateProcess proc
bracketOnError (createProcess proc) undo $ \(a,b,c,d) -> f a b c d
startGhciProcess :: CreateProcess -> (Stream -> String -> IO ()) -> IO (Ghci, [Load])
startGhciProcess process echo0 = do
let proc = process{std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe, create_group=True}
withCreateProc proc $ \(Just inp) (Just out) (Just err) ghciProcess -> do
hSetBuffering out LineBuffering
hSetBuffering err LineBuffering
hSetBuffering inp LineBuffering
let writeInp x = do
whenLoud $ outStrLn $ "%STDIN: " ++ x
hPutStrLn inp x
hPutStrLn inp ""
let ghcid_prefix = "#~GHCID-START~#"
let removePrefix = dropPrefixRepeatedly ghcid_prefix
syncCount <- newVar 0
let syncReplay = do
i <- readVar syncCount
let showStr xs = "[" ++ intercalate "," (map show xs) ++ "]"
let msg = "#~GHCID-FINISH-" ++ show i ++ "~#"
writeInp $ "\nINTERNAL_GHCID.putStrLn " ++ showStr msg ++ "\n" ++
"INTERNAL_GHCID.hPutStrLn INTERNAL_GHCID.stderr " ++ showStr msg
pure $ isInfixOf msg
let syncFresh = do
modifyVar_ syncCount $ pure . succ
syncReplay
let consume :: Stream -> (String -> IO (Maybe a)) -> IO (Either (Maybe String) a)
consume name finish = do
let h = if name == Stdout then out else err
flip fix Nothing $ \rec oldMsg -> do
el <- tryBool isEOFError $ hGetLine h
case el of
Left _ -> pure $ Left oldMsg
Right l -> do
whenLoud $ outStrLn $ "%" ++ upper (show name) ++ ": " ++ l
let msg = removePrefix l
res <- finish msg
case res of
Nothing -> rec $ Just msg
Just a -> pure $ Right a
let consume2 :: String -> (Stream -> String -> IO (Maybe a)) -> IO (a,a)
consume2 msg finish = do
res1 <- onceFork $ consume Stdout (finish Stdout)
res2 <- onceFork $ consume Stderr (finish Stderr)
res1 <- res1
res2 <- res2
let raise msg err = throwIO $ case cmdspec process of
ShellCommand cmd -> UnexpectedExit cmd msg err
RawCommand exe args -> UnexpectedExit (unwords (exe:args)) msg err
case (res1, res2) of
(Right v1, Right v2) -> pure (v1, v2)
(_, Left err) -> raise msg err
(_, Right _) -> raise msg Nothing
isInterrupting <- newLock
isRunning <- newLock
let ghciExec command echo = do
withLock isInterrupting $ pure ()
res <- withLockTry isRunning $ do
writeInp command
stop <- syncFresh
void $ consume2 command $ \strm s ->
if stop s then pure $ Just () else do echo strm s; pure Nothing
when (isNothing res) $
fail "Ghcid.exec, computation is already running, must be used single-threaded"
let ghciInterrupt = withLock isInterrupting $
whenM (fmap isNothing $ withLockTry isRunning $ pure ()) $ do
whenLoud $ outStrLn "%INTERRUPT"
interruptProcessGroupOf ghciProcess
syncReplay
withLock isRunning $ pure ()
stop <- syncFresh
void $ consume2 "Interrupt" $ \_ s -> pure $ if stop s then Just () else Nothing
ghciUnique <- newUnique
let ghci = Ghci{..}
stdout <- newIORef []
stderr <- newIORef []
sync <- newIORef $ const False
consume2 "" $ \strm s -> do
stop <- readIORef sync
if stop s then
pure $ Just ()
else do
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
writeIORef stdout []
writeIORef stderr []
writeInp "import qualified System.IO as INTERNAL_GHCID"
writeInp ":unset +t +s"
writeInp $ ":set prompt " ++ ghcid_prefix
forM_ (ghciFlagsRequired ++ ghciFlagsRequiredVersioned) $ \flag ->
writeInp $ ":set " ++ flag
writeIORef sync =<< syncFresh
echo0 strm s
pure Nothing
r1 <- parseLoad . reverse <$> ((++) <$> readIORef stderr <*> readIORef stdout)
r2 <- if any isLoading r1 then pure [] else map (uncurry Loading) <$> showModules ghci
execStream ghci "" echo0
pure (ghci, r1 ++ r2)
startGhci
:: String
-> Maybe FilePath
-> (Stream -> String -> IO ())
-> IO (Ghci, [Load])
startGhci cmd directory = startGhciProcess (shell cmd){cwd=directory}
execStream :: Ghci -> String -> (Stream -> String -> IO ()) -> IO ()
execStream = ghciExec
interrupt :: Ghci -> IO ()
interrupt = ghciInterrupt
process :: Ghci -> ProcessHandle
process = ghciProcess
execBuffer :: Ghci -> String -> (Stream -> String -> IO ()) -> IO [String]
execBuffer ghci cmd echo = do
stdout <- newIORef []
stderr <- newIORef []
execStream ghci cmd $ \strm s -> do
modifyIORef (if strm == Stdout then stdout else stderr) (s:)
echo strm s
reverse <$> ((++) <$> readIORef stderr <*> readIORef stdout)
exec :: Ghci -> String -> IO [String]
exec ghci cmd = execBuffer ghci cmd $ \_ _ -> pure ()
showModules :: Ghci -> IO [(String,FilePath)]
showModules ghci = parseShowModules <$> exec ghci ":show modules"
showPaths :: Ghci -> IO (FilePath, [FilePath])
showPaths ghci = parseShowPaths <$> exec ghci ":show paths"
reload :: Ghci -> IO [Load]
reload ghci = parseLoad <$> exec ghci ":reload"
quit :: Ghci -> IO ()
quit ghci = do
interrupt ghci
handle (\UnexpectedExit{} -> pure ()) $ void $ exec ghci ":quit"
ignored $ void $ waitForProcess $ process ghci
stopGhci :: Ghci -> IO ()
stopGhci ghci = do
forkIO $ do
sleep 5
terminateProcess $ process ghci
quit ghci