{-# OPTIONS_GHC -XRecordWildCards -XCPP -XBangPatterns -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.Tool -- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken -- License : GPL -- -- Maintainer : -- 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(..), toolProcess, newToolState, runTool, runTool', runInteractiveTool, newGhci, executeCommand, executeGhciCommand, quoteArg, escapeQuotes, -- waitForChildren, -- forkChild ) where import Control.Concurrent (readMVar, takeMVar, putMVar, newEmptyMVar, forkIO, newChan, MVar, Chan, writeChan, getChanContents, dupChan) import Control.Monad (unless, when) import Data.List (stripPrefix) import Data.Maybe (isJust, catMaybes) import IDE.System.Process (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..)) import IDE.System.Process.Internals (StdStream(..)) import Control.DeepSeq import System.Log.Logger (debugM, criticalM) import System.Exit (ExitCode(..)) import System.IO (hGetContents, hFlush, hPutStrLn, Handle) import Control.Applicative ((<$>)) import Data.Char (isNumber) data ToolOutput = ToolInput String | ToolError String | ToolOutput String | ToolPrompt | 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 (ToolPrompt) = rnf () rnf (ToolExit code) = rnf code data ToolCommand = ToolCommand String ([ToolOutput] -> IO ()) data ToolState = ToolState { toolProcessMVar :: MVar ProcessHandle, outputClosed :: MVar Bool, toolCommands :: Chan ToolCommand, toolCommandsRead :: Chan ToolCommand, currentToolCommand :: MVar ToolCommand} toolProcess :: ToolState -> IO ProcessHandle toolProcess = readMVar . toolProcessMVar data RawToolOutput = RawToolOutput ToolOutput | ToolOutClosed | ToolErrClosed | ToolClosed deriving(Eq, Show) toolline :: ToolOutput -> String toolline (ToolInput l) = l toolline (ToolOutput l) = l toolline (ToolError l) = l toolline (ToolPrompt) = "" 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 (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, cwd = mbDir, new_group = True } output <- getOutputNoPrompt inp out err pid return (output, pid) newToolState :: IO ToolState newToolState = do toolProcessMVar <- newEmptyMVar outputClosed <- newEmptyMVar toolCommands <- newChan toolCommandsRead <- dupChan toolCommands currentToolCommand <- newEmptyMVar return ToolState{..} runInteractiveTool :: ToolState -> CommandLineReader -> FilePath -> [String] -> IO () runInteractiveTool tool clr executable arguments = do (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, new_group = True } putMVar (toolProcessMVar tool) pid output <- getOutput clr inp out err pid -- This is handy to show the processed output -- forkIO $ forM_ output (putStrLn.show) forkIO $ do commands <- getChanContents (toolCommandsRead tool) processCommand 0 commands inp output return () where processCommand _ [] _ _ = do debugM "leksah-server" $ "No More Commands" return () processCommand n ((command@(ToolCommand commandString handler)):remainingCommands) inp allOutput = do putMVar (currentToolCommand tool) command hPutStrLn inp commandString hFlush inp outputChan <- newChan outputChan' <- dupChan outputChan done <- newEmptyMVar forkIO $ do output <- fromRawOutput <$> getChanContents outputChan' debugM "leksah-server" $ "Start Processing Tool Output for " ++ commandString handler $ (map ToolInput (lines commandString)) ++ output debugM "leksah-server" $ "Done Processing Tool Output for " ++ commandString putMVar done True return () remainingOutputWithPrompt <- writeCommandOutput outputChan inp allOutput False False (outputSyncCommand clr) n takeMVar done takeMVar (currentToolCommand tool) case remainingOutputWithPrompt of (RawToolOutput ToolPrompt:remainingOutput) -> do debugM "leksah-server" $ "Ready For Next Command" processCommand (n+1) 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" writeCommandOutput _ _ [] _ _ _ _ = do criticalM "leksah-server" $ "ToolExit not found" return [] writeCommandOutput out inp (RawToolOutput ToolPrompt:remainingOutput) False False (Just outSyncCmd) n = do debugM "leksah-server" $ "Pre Sync Prompt" hPutStrLn inp $ outSyncCmd n hFlush inp writeCommandOutput out inp remainingOutput True False (Just outSyncCmd) n writeCommandOutput out inp (RawToolOutput ToolPrompt:remainingOutput) True False (Just outSyncCmd) n = do debugM "leksah-server" $ "Unsynced Prompt" writeCommandOutput out inp remainingOutput True False (Just outSyncCmd) n writeCommandOutput out inp (o@(RawToolOutput (ToolOutput line)):remainingOutput) True False (Just outSyncCmd) n = do let synced = (isExpectedOutput clr n line) unless synced $ writeChan out o when synced $ debugM "leksah-server" $ "Output Sync Found" writeCommandOutput out inp remainingOutput True synced (Just outSyncCmd) n writeCommandOutput out _ remainingOutput@(RawToolOutput ToolPrompt:_) _ _ _ _ = do debugM "leksah-server" $ "Synced Prompt" writeChan out $ RawToolOutput ToolPrompt return remainingOutput writeCommandOutput out _ (o@(RawToolOutput (ToolExit _)):_) _ _ _ _ = do debugM "leksah-server" $ "Tool Exit" writeChan out o return [] writeCommandOutput out inp (o:remainingOutput) synching synched syncCmd n = do writeChan out o writeCommandOutput out inp remainingOutput synching synched syncCmd n {- 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 (Int -> String), stripExpectedError :: String -> Maybe (Int, String), outputSyncCommand :: Maybe (Int -> String), isExpectedOutput :: Int -> String -> Bool } 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 {- stripMarker $ marker 0 ++ "dfskfjdkl" -} marker :: Int -> String marker n = take (29 - length num) "kMAKWRALZZbHdXfHUOAAYBBsJVYoC" ++ num where num = show n stripMarker :: String -> Maybe (Int, String) stripMarker s = case strip "kMAKWRALZZbHdXfHUOAAYBBsJVYoC" s of Just (nums, rest) -> Just (read nums, rest) Nothing -> Nothing where strip :: String -> String -> Maybe (String, String) strip letters@(a:as) input@(b:bs) | a == b = strip as bs | otherwise = numbers letters input strip _ _ = Nothing numbers :: String -> String -> Maybe (String, String) numbers (_:as) (n:ns) | isNumber n = case numbers as ns of Just (nums, rest) -> Just (n:nums, rest) _ -> Nothing | otherwise = Nothing numbers [] input = Just ([], input) numbers _ _ = Nothing ghciStripExpectedError :: String -> Maybe (Int, String) ghciStripExpectedError output = case stripPrefix "\n:1:0" output of Just rest -> case stripPrefix ": Not in scope: `" (maybe rest id (stripPrefix "-28" rest)) of Just rest2 -> case stripMarker rest2 of Just (n, rest3) -> case stripPrefix "'\n" rest3 of Just rest4 -> Just (n, rest4) Nothing -> Nothing Nothing -> Nothing Nothing -> Nothing Nothing -> Nothing ghciIsExpectedOutput :: Int -> String -> Bool ghciIsExpectedOutput n = (==) (marker n) ghciCommandLineReader :: CommandLineReader ghciCommandLineReader = CommandLineReader { stripInitialPrompt = ghciStripInitialPrompt, stripFollowingPrompt = ghciStripFollowingPrompt, errorSyncCommand = Just $ \n -> marker n, stripExpectedError = ghciStripExpectedError, outputSyncCommand = Just $ \n -> ":set prompt " ++ marker n ++ "\n:set prompt " ++ ghciPrompt, isExpectedOutput = ghciIsExpectedOutput } noInputCommandLineReader :: CommandLineReader noInputCommandLineReader = CommandLineReader { stripInitialPrompt = const Nothing, stripFollowingPrompt = const Nothing, errorSyncCommand = Nothing, stripExpectedError = \_ -> Nothing, outputSyncCommand = Nothing, isExpectedOutput = \_ _ -> False } --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) 0 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 (counter, unexpectedErrors) -> do putMVar foundExpectedError counter 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 counter foundExpectedError errSynced = do let stripPrompt = (if counter==0 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 counter foundExpectedError errSynced _ -> do when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line case stripPrompt remaining of Just afterPrompt -> do case (counter, errSynced, errorSyncCommand clr) of (0, _, _) -> do readOutput chan afterPrompt (counter+1) foundExpectedError errSynced (_, False, Just syncCmd) -> do hPutStrLn inp $ syncCmd counter hFlush inp waitForError counter foundExpectedError readOutput chan afterPrompt (counter+1) foundExpectedError True _ -> do writeChan chan $ RawToolOutput ToolPrompt readOutput chan afterPrompt (counter+1) foundExpectedError False _ -> return () -- Should never happen getOutputLine _ [] = [] getOutputLine _ ('\n':_) = [] getOutputLine stripPrompt output@(x:xs) | isJust (stripPrompt output) = [] | otherwise = x : (getOutputLine stripPrompt xs) waitForError counter foundExpectedError = do foundCount <- takeMVar foundExpectedError when (foundCount < counter) $ waitForError counter foundExpectedError fromRawOutput :: [RawToolOutput] -> [ToolOutput] fromRawOutput [] = [] fromRawOutput (RawToolOutput (ToolPrompt):_) = [ToolPrompt] fromRawOutput (RawToolOutput (ToolExit code):_) = [ToolExit code] fromRawOutput (RawToolOutput output:xs) = output : (fromRawOutput xs) fromRawOutput (_:xs) = fromRawOutput xs 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 ghciCommandLineReader "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 ())