leksah-server-0.8: src/IDE/Utils/Tool.hs
{-# OPTIONS_GHC -XRecordWildCards -XCPP -XBangPatterns -fno-warn-orphans #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Utils.Tool
-- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken
-- License : GPL
--
-- Maintainer : <maintainer@leksah.org>
-- Stability : provisional
-- Portability :
--
-- | Support for running external tools. Written mainly for GHCi but with
-- | support for others in mind.
--
-----------------------------------------------------------------------------
module IDE.Utils.Tool (
ToolOutput(..),
toolline,
ToolCommand(..),
ToolState(..),
newToolState,
runTool,
runTool',
runInteractiveTool,
newGhci,
executeCommand,
executeGhciCommand,
quoteArg,
escapeQuotes,
-- waitForChildren,
-- forkChild
) where
import Control.Concurrent
(takeMVar,
putMVar,
newEmptyMVar,
forkIO,
newChan,
MVar,
Chan,
writeChan,
getChanContents,
dupChan)
import Control.Monad (when)
import Data.List (stripPrefix)
import Data.Maybe (isJust, catMaybes)
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
import System.Posix (sigQUIT, sigINT, installHandler)
import System.Posix.Signals (Handler(..))
#endif
import System.Process
(waitForProcess, ProcessHandle, runInteractiveProcess)
import Control.DeepSeq
import System.Log.Logger (debugM, criticalM)
import System.Exit (ExitCode(..))
import System.IO (hGetContents, hFlush, hPutStrLn, Handle)
data ToolOutput = ToolInput String | ToolError String | ToolOutput String | ToolExit ExitCode deriving(Eq, Show)
instance NFData ExitCode where
rnf ExitSuccess = rnf ()
rnf (ExitFailure failureCode) = rnf failureCode
instance NFData ToolOutput where
rnf (ToolInput s) = rnf s
rnf (ToolError s) = rnf s
rnf (ToolOutput s) = rnf s
rnf (ToolExit code) = rnf code
data ToolCommand = ToolCommand String ([ToolOutput] -> IO ())
data ToolState = ToolState {
toolProcess :: MVar ProcessHandle,
outputClosed :: MVar Bool,
toolCommands :: Chan ToolCommand,
toolCommandsRead :: Chan ToolCommand,
currentToolCommand :: MVar ToolCommand}
data RawToolOutput = RawToolOutput ToolOutput
| ToolPrompt
| ToolOutClosed
| ToolErrClosed
| ToolClosed deriving(Eq, Show)
toolline :: ToolOutput -> String
toolline (ToolInput l) = l
toolline (ToolOutput l) = l
toolline (ToolError l) = l
toolline (ToolExit _code) = []
quoteArg :: String -> String
quoteArg s | ' ' `elem` s = "\"" ++ (escapeQuotes s) ++ "\""
quoteArg s = s
escapeQuotes :: String -> String
escapeQuotes = foldr (\c s -> if c == '"' then '\\':c:s else c:s) ""
runTool' :: FilePath -> [String] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle)
runTool' fp args mbDir = do
debugM "leksah-server" $ "Start: " ++ show (fp, args)
(out,pid) <- runTool fp args mbDir
deepseq out $ waitForProcess pid
debugM "leksah-server" $ "End: " ++ show (fp, args)
return (out,pid)
runTool :: FilePath -> [String] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle)
runTool executable arguments mbDir = do
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
installHandler sigINT Ignore Nothing
installHandler sigQUIT Ignore Nothing
#endif
(inp,out,err,pid) <- runInteractiveProcess executable arguments mbDir Nothing
output <- getOutputNoPrompt inp out err pid
return (output, pid)
newToolState :: IO ToolState
newToolState = do
toolProcess <- newEmptyMVar
outputClosed <- newEmptyMVar
toolCommands <- newChan
toolCommandsRead <- dupChan toolCommands
currentToolCommand <- newEmptyMVar
return ToolState{..}
runInteractiveTool :: ToolState -> (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ()
runInteractiveTool tool getOutput' executable arguments = do
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
installHandler sigINT Ignore Nothing
installHandler sigQUIT Ignore Nothing
#endif
(inp,out,err,pid) <- runInteractiveProcess executable arguments Nothing Nothing
putMVar (toolProcess tool) pid
output <- getOutput' inp out err pid
-- This is handy to show the processed output
-- forkIO $ forM_ output (putStrLn.show)
forkIO $ do
commands <- getChanContents (toolCommandsRead tool)
processCommand commands inp output
return ()
where
processCommand [] _ _ = return ()
processCommand ((command@(ToolCommand commandString handler)):remainingCommands) inp allOutput = do
putMVar (currentToolCommand tool) command
hPutStrLn inp commandString
hFlush inp
let (output, remainingOutputWithPrompt) = span (/= ToolPrompt) allOutput
debugM "leksah-server" $ "Start Processing Tool Output for " ++ commandString
handler $ (map ToolInput (lines commandString)) ++ fromRawOutput output
debugM "leksah-server" $ "Done Processing Tool Output for " ++ commandString
takeMVar (currentToolCommand tool)
case remainingOutputWithPrompt of
(ToolPrompt:remainingOutput) -> do
debugM "leksah-server" $ "Prompt"
processCommand remainingCommands inp remainingOutput
[] -> do
debugM "leksah-server" $ "Tool Output Closed"
putMVar (outputClosed tool) True
_ -> do
criticalM "leksah-server" $ "This should never happen in Tool.hs"
{-
newInteractiveTool :: (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ToolState
newInteractiveTool getOutput' executable arguments = do
tool <- newToolState
runInteractiveTool tool getOutput' executable arguments
return tool
-}
ghciPrompt :: String
ghciPrompt = "3KM2KWR7LZZbHdXfHUOA5YBBsJVYoCQnKX"
data CommandLineReader = CommandLineReader {
stripInitialPrompt :: String -> Maybe String,
stripFollowingPrompt :: String -> Maybe String,
errorSyncCommand :: Maybe String,
stripExpectedError :: String -> Maybe String
}
ghciStripInitialPrompt :: String -> Maybe String
ghciStripInitialPrompt output =
case catMaybes [stripPrefix "Prelude" output, stripPrefix "*" output] of
remaining:_ ->
case dropWhile (/= '>') remaining of
'>':' ':next -> Just next
_ -> Nothing
_ -> Nothing
ghciStripFollowingPrompt :: String -> Maybe String
ghciStripFollowingPrompt = stripPrefix ghciPrompt
ghciStripExpectedError :: String -> Maybe String
ghciStripExpectedError output = case stripPrefix "\n<interactive>:1:0" output of
Just rest ->
stripPrefix ": Not in scope: `kM2KWR7LZZbHdXfHUOA5YBBsJVYoC'\n"
(maybe rest id (stripPrefix "-28" rest))
Nothing -> Nothing
ghciCommandLineReader :: CommandLineReader
ghciCommandLineReader = CommandLineReader {
stripInitialPrompt = ghciStripInitialPrompt,
stripFollowingPrompt = ghciStripFollowingPrompt,
errorSyncCommand = Just "kM2KWR7LZZbHdXfHUOA5YBBsJVYoC",
stripExpectedError = ghciStripExpectedError
}
noInputCommandLineReader :: CommandLineReader
noInputCommandLineReader = CommandLineReader {
stripInitialPrompt = const Nothing,
stripFollowingPrompt = const Nothing,
errorSyncCommand = Nothing,
stripExpectedError = const Nothing
}
--waitTillEmpty :: Handle -> IO ()
--waitTillEmpty handle = do
-- ready <- hReady handle
-- when ready $ do
-- yield
-- threadDelay 100
-- yield
-- waitTillEmpty handle
getOutput :: CommandLineReader -> Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]
getOutput clr inp out err pid = do
chan <- newChan
testClosed <- dupChan chan
-- hSetBuffering out NoBuffering
-- hSetBuffering err NoBuffering
foundExpectedError <- newEmptyMVar
-- Use this and the too putStr threads bellow if you want to see the raw output
-- hSetBuffering stdout NoBuffering
forkIO $ do
errors <- hGetContents err
-- forkIO $ putStr errors
readError chan (filter (/= '\r') errors) foundExpectedError
writeChan chan ToolErrClosed
forkIO $ do
output <- hGetContents out
-- forkIO $ putStr output
readOutput chan (filter (/= '\r') output) True foundExpectedError False
writeChan chan ToolOutClosed
forkIO $ do
output <- getChanContents testClosed
when ((ToolOutClosed `elem` output) && (ToolErrClosed `elem` output)) $ do
exitCode <- waitForProcess pid
writeChan chan (RawToolOutput (ToolExit exitCode))
writeChan chan ToolClosed
debugM "leksah-server" $ "Tool Exited " ++ show exitCode
fmap (takeWhile ((/=) ToolClosed)) $ getChanContents chan
where
readError chan errors foundExpectedError = do
case stripExpectedError clr errors of
Just unexpectedErrors -> do
putMVar foundExpectedError True
readError chan unexpectedErrors foundExpectedError
Nothing -> do
let (line, remaining) = break (== '\n') errors
case remaining of
[] -> return ()
_:remainingLines -> do
writeChan chan $ RawToolOutput $ ToolError line
readError chan remainingLines foundExpectedError
readOutput chan output initial foundExpectedError synced = do
let stripPrompt = (if initial then (stripInitialPrompt clr) else (stripFollowingPrompt clr))
let line = getOutputLine stripPrompt output
let remaining = drop (length line) output
case remaining of
[] -> do
when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line
'\n':remainingLines -> do
writeChan chan $ RawToolOutput $ ToolOutput line
readOutput chan remainingLines initial foundExpectedError synced
_ -> do
when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line
case stripPrompt remaining of
Just afterPrompt -> do
case (initial, synced, errorSyncCommand clr) of
(True, _, _) -> do
readOutput chan afterPrompt False foundExpectedError synced
(False, _, Nothing) -> do
writeChan chan ToolPrompt
readOutput chan afterPrompt False foundExpectedError synced
(False, False, Just syncCmd) -> do
hPutStrLn inp syncCmd
hFlush inp
takeMVar foundExpectedError
readOutput chan afterPrompt False foundExpectedError True
(False, True, Just _) -> do
writeChan chan ToolPrompt
readOutput chan afterPrompt False foundExpectedError False
_ -> return () -- Should never happen
getOutputLine _ [] = []
getOutputLine _ ('\n':_) = []
getOutputLine stripPrompt output@(x:xs)
| isJust (stripPrompt output) = []
| otherwise = x : (getOutputLine stripPrompt xs)
fromRawOutput :: [RawToolOutput] -> [ToolOutput]
fromRawOutput [] = []
fromRawOutput (RawToolOutput (ToolExit code):_) = [ToolExit code]
fromRawOutput (RawToolOutput output:xs) = output : (fromRawOutput xs)
fromRawOutput (_:xs) = fromRawOutput xs
getGhciOutput :: Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]
getGhciOutput = getOutput ghciCommandLineReader
getOutputNoPrompt :: Handle -> Handle -> Handle -> ProcessHandle -> IO [ToolOutput]
getOutputNoPrompt inp out err pid = fmap fromRawOutput $ getOutput noInputCommandLineReader inp out err pid
newGhci :: [String] -> [String] -> ([ToolOutput] -> IO ()) -> IO ToolState
newGhci buildFlags interactiveFlags startupOutputHandler = do
tool <- newToolState
writeChan (toolCommands tool) $
ToolCommand (":set prompt " ++ ghciPrompt) startupOutputHandler
debugM "leksah-server" $ "Working out GHCi options"
forkIO $ do
(output, _) <- runTool "runhaskell" (["Setup","build","--with-ghc=leksahecho"] ++ buildFlags) Nothing
case catMaybes $ map (findMake . toolline) output of
options:_ -> do
let newOptions = filterUnwanted options
debugM "leksah-server" $ newOptions
debugM "leksah-server" $ "Starting GHCi"
debugM "leksah-server" $ unwords (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags)
runInteractiveTool tool getGhciOutput "ghci"
(words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags)
_ -> do
startupOutputHandler output
putMVar (outputClosed tool) True
return tool
where
findMake [] = Nothing
findMake line@(_:xs) =
case stripPrefix " --make " line of
Nothing -> findMake xs
s -> s
filterUnwanted [] = []
filterUnwanted line@(x:xs) =
case stripPrefix "-O " line of
Nothing -> x: filterUnwanted xs
Just s -> filterUnwanted s
executeCommand :: ToolState -> String -> ([ToolOutput] -> IO ()) -> IO ()
executeCommand tool command handler = do
writeChan (toolCommands tool) $ ToolCommand command handler
executeGhciCommand :: ToolState -> String -> ([ToolOutput] -> IO ()) -> IO ()
executeGhciCommand tool command handler = do
if '\n' `elem` command
then executeCommand tool safeCommand $ \output -> do
handler $ fixInput $ fixOutput output
else executeCommand tool command handler
where
filteredLines = (filter safeLine (lines command))
promptCount = (length filteredLines)+1
safeCommand = (unlines ([":{"] ++ filteredLines)) ++ ":}"
safeLine ":{" = False
safeLine ":}" = False
safeLine _ = True
fixOutput ((ToolOutput line):xs) = (ToolOutput (removePrompts line line promptCount)):xs
fixOutput (x:xs) = x:(fixOutput xs)
fixOutput [] = []
fixInput = filter (\x -> (x /= ToolInput ":{") && (x /= ToolInput ":}"))
removePrompts _fullLine line 0 = line
removePrompts fullLine line n = case dropWhile ((/=) '|') line of
'|':' ':xs -> removePrompts fullLine xs (n-1)
_ -> fullLine
--children :: MVar [MVar ()]
--children = unsafePerformIO (newMVar [])
--
--waitForChildren :: IO ()
--waitForChildren = do
-- cs <- takeMVar children
-- case cs of
-- [] -> return ()
-- m:ms -> do
-- putMVar children ms
-- takeMVar m
-- waitForChildren
--
--forkChild :: IO () -> IO ThreadId
--forkChild io = do
-- mvar <- newEmptyMVar
-- childs <- takeMVar children
-- putMVar children (mvar:childs)
-- forkIO (io `finally` putMVar mvar ())