module Test.TBC.Drivers
( Driver(..)
, ghci
) where
import Prelude hiding ( catch )
import Control.Exception ( catch, SomeException )
import Control.Concurrent
import Control.Monad ( liftM )
import Data.List ( isInfixOf )
import Distribution.Simple.Utils ( info, debug )
import Distribution.Verbosity ( Verbosity )
import System.Exit
import System.IO
import System.Process ( runInteractiveProcess, waitForProcess, terminateProcess )
data Driver
= MkDriver
{ hci_send_cmd :: String -> IO [String]
, hci_load_file :: String -> IO [String]
, hci_kill :: IO ()
, hci_close :: IO ExitCode
}
ghci :: Verbosity
-> String
-> [String]
-> IO Driver
ghci verbosity cmd flags =
do let extra_flags = []
debug verbosity $
unlines [ "system $ " ++ cmd ++ " " ++ concat [ ' ' : a | a <- flags ++ extra_flags ]
, "----------------------------------------" ]
(hin, hout, herr, hpid)
<- runInteractiveProcess cmd flags Nothing Nothing
hPutStrLn hin ":set prompt \"\""
hPutStrLn hin "GHC.Handle.hDuplicateTo System.IO.stdout System.IO.stderr"
hPutStrLn hin ":s -package deepseq"
let load_file f =
do cout <- ghci_sync verbosity hin hout (":l *" ++ f ++ "\n")
return $ if not (null cout) && "Ok, modules loaded" `isInfixOf` last cout
then []
else cout
return $ MkDriver
{ hci_send_cmd = ghci_sync verbosity hin hout
, hci_load_file = load_file
, hci_kill = terminateProcess hpid
, hci_close = do hPutStr hin ":quit\n"
hFlush hin `catch` (const (return ()) :: (SomeException -> IO ()))
waitForProcess hpid
}
ghci_sync :: Verbosity
-> Handle -> Handle -> String -> IO [String]
ghci_sync verbosity hin hout inp =
do info verbosity $
"--Sync----------------------------------\n"
++ inp
++ "----------------------------------------\n"
outMVar <- newEmptyMVar
_ <- forkIO $ hc_sync hout >>= putMVar outMVar
hPutStr hin inp
hPutStr hin hc_sync_print
hFlush hin `catch` ghciDiedEH outMVar
hc_output <- lint_output `liftM` takeMVar outMVar
info verbosity $
unlines ( ">> Output <<" : hc_output )
return hc_output
where
lint_output :: [[a]] -> [[a]]
lint_output = reverse . dropWhile null . reverse . dropWhile null
done :: String
done = ">>>>done<<<<"
hc_sync_print :: String
hc_sync_print = "System.IO.putStrLn \"" ++ done ++ "\"\n"
hc_sync :: Handle -> IO [String]
hc_sync h = sync
where
sync =
do eof <- hIsEOF h
if eof
then return []
else do l <- hGetLine h
info verbosity $ "hc>> " ++ l
if done `isInfixOf` l
then return []
else (l:) `liftM` sync
ghciDiedEH outMVar e =
do hc_output <- takeMVar outMVar
putStr $ unlines ( ">> GHCi died. Output <<" : hc_output )
ioError e