commit
f95afdd34e
@ -260,11 +260,11 @@ pdynload object incpaths pkgconfs ty sym = do
|
|||||||
#if DEBUG
|
#if DEBUG
|
||||||
putStr "Checking types ... " >> hFlush stdout
|
putStr "Checking types ... " >> hFlush stdout
|
||||||
#endif
|
#endif
|
||||||
errors <- unify object incpaths [] ty sym
|
(errors, success) <- unify object incpaths [] ty sym
|
||||||
#if DEBUG
|
#if DEBUG
|
||||||
putStrLn "done"
|
putStrLn "done"
|
||||||
#endif
|
#endif
|
||||||
if null errors
|
if success
|
||||||
then load object incpaths pkgconfs sym
|
then load object incpaths pkgconfs sym
|
||||||
else return $ LoadFailure errors
|
else return $ LoadFailure errors
|
||||||
|
|
||||||
@ -284,11 +284,11 @@ pdynload_ object incpaths pkgconfs args ty sym = do
|
|||||||
#if DEBUG
|
#if DEBUG
|
||||||
putStr "Checking types ... " >> hFlush stdout
|
putStr "Checking types ... " >> hFlush stdout
|
||||||
#endif
|
#endif
|
||||||
errors <- unify object incpaths args ty sym
|
(errors, success) <- unify object incpaths args ty sym
|
||||||
#if DEBUG
|
#if DEBUG
|
||||||
putStrLn "done"
|
putStrLn "done"
|
||||||
#endif
|
#endif
|
||||||
if null errors
|
if success
|
||||||
then load object incpaths pkgconfs sym
|
then load object incpaths pkgconfs sym
|
||||||
else return $ LoadFailure errors
|
else return $ LoadFailure errors
|
||||||
|
|
||||||
@ -317,9 +317,9 @@ unify obj incs args ty sym = do
|
|||||||
|
|
||||||
hWrite hdl src
|
hWrite hdl src
|
||||||
|
|
||||||
e <- build tmpf tmpf1 (i:is++args++["-fno-code","-c","-ohi "++tmpf1])
|
(e,success) <- build tmpf tmpf1 (i:is++args++["-fno-code","-c","-ohi "++tmpf1])
|
||||||
mapM_ removeFile [tmpf,tmpf1]
|
mapM_ removeFile [tmpf,tmpf1]
|
||||||
return e
|
return (e, success)
|
||||||
|
|
||||||
where
|
where
|
||||||
-- fix up hierarchical names
|
-- fix up hierarchical names
|
||||||
|
@ -269,11 +269,11 @@ rawMake src args docheck = do
|
|||||||
#if DEBUG
|
#if DEBUG
|
||||||
putStr "Compiling object ... " >> hFlush stdout
|
putStr "Compiling object ... " >> hFlush stdout
|
||||||
#endif
|
#endif
|
||||||
err <- build src obj args
|
(err, success) <- build src obj args
|
||||||
#if DEBUG
|
#if DEBUG
|
||||||
putStrLn "done"
|
putStrLn "done"
|
||||||
#endif
|
#endif
|
||||||
return $ if null err
|
return $ if success
|
||||||
then MakeSuccess ReComp obj
|
then MakeSuccess ReComp obj
|
||||||
else MakeFailure err
|
else MakeFailure err
|
||||||
}
|
}
|
||||||
@ -287,7 +287,7 @@ rawMake src args docheck = do
|
|||||||
build :: FilePath -- ^ path to .hs source
|
build :: FilePath -- ^ path to .hs source
|
||||||
-> FilePath -- ^ path to object file
|
-> FilePath -- ^ path to object file
|
||||||
-> [String] -- ^ any extra cmd line flags
|
-> [String] -- ^ any extra cmd line flags
|
||||||
-> IO [String]
|
-> IO ([String], Bool)
|
||||||
|
|
||||||
build src obj extra_opts = do
|
build src obj extra_opts = do
|
||||||
|
|
||||||
@ -306,12 +306,12 @@ build src obj extra_opts = do
|
|||||||
putStr $ show $ ghc : flags
|
putStr $ show $ ghc : flags
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
(_out,err) <- exec ghc flags -- this is a fork()
|
(_out,err,success) <- exec ghc flags -- this is a fork()
|
||||||
|
|
||||||
obj_exists <- doesFileExist obj -- sanity
|
obj_exists <- doesFileExist obj -- sanity
|
||||||
return $ if not obj_exists && null err -- no errors, but no object?
|
return $ if not obj_exists && success
|
||||||
then ["Compiled, but didn't create object file `"++obj++"'!"]
|
then (["Compiled, but didn't create object file `"++obj++"'!"], success)
|
||||||
else err
|
else (err, success)
|
||||||
|
|
||||||
-- ---------------------------------------------------------------------
|
-- ---------------------------------------------------------------------
|
||||||
-- | Merge to source files into a temporary file. If we've tried to
|
-- | Merge to source files into a temporary file. If we've tried to
|
||||||
|
@ -7,25 +7,19 @@
|
|||||||
module System.Plugins.Process (exec, popen) where
|
module System.Plugins.Process (exec, popen) where
|
||||||
|
|
||||||
import System.Exit
|
import System.Exit
|
||||||
#if __GLASGOW_HASKELL__ >= 604
|
|
||||||
import System.IO
|
import System.IO
|
||||||
import System.Process
|
import System.Process
|
||||||
import Control.Concurrent (forkIO)
|
import Control.Concurrent (forkIO)
|
||||||
#else
|
|
||||||
import qualified Posix as P
|
|
||||||
#endif
|
|
||||||
|
|
||||||
import qualified Control.Exception as E
|
import qualified Control.Exception as E
|
||||||
|
|
||||||
--
|
--
|
||||||
-- slight wrapper over popen for calls that don't care about stdin to the program
|
-- slight wrapper over popen for calls that don't care about stdin to the program
|
||||||
--
|
--
|
||||||
exec :: String -> [String] -> IO ([String],[String])
|
exec :: String -> [String] -> IO ([String],[String],Bool)
|
||||||
exec f as = do
|
exec f as = do
|
||||||
(a,b,_) <- popen f as (Just [])
|
(a,b,c,_) <- popen f as (Just [])
|
||||||
return (lines a, lines b)
|
return (lines a, lines b,c)
|
||||||
|
|
||||||
#if __GLASGOW_HASKELL__ >= 604
|
|
||||||
|
|
||||||
type ProcessID = ProcessHandle
|
type ProcessID = ProcessHandle
|
||||||
|
|
||||||
@ -37,9 +31,9 @@ type ProcessID = ProcessHandle
|
|||||||
-- Posix.popen doesn't have this problem, so maybe we can reproduce its
|
-- Posix.popen doesn't have this problem, so maybe we can reproduce its
|
||||||
-- pipe handling somehow.
|
-- pipe handling somehow.
|
||||||
--
|
--
|
||||||
popen :: FilePath -> [String] -> Maybe String -> IO (String,String,ProcessID)
|
popen :: FilePath -> [String] -> Maybe String -> IO (String,String,Bool,ProcessID)
|
||||||
popen file args minput =
|
popen file args minput =
|
||||||
E.handle (\e -> return ([],show (e::E.IOException), error (show e))) $ do
|
E.handle (\e -> return ([],show (e::E.IOException), False, error (show e))) $ do
|
||||||
|
|
||||||
(inp,out,err,pid) <- runInteractiveProcess file args Nothing Nothing
|
(inp,out,err,pid) <- runInteractiveProcess file args Nothing Nothing
|
||||||
|
|
||||||
@ -64,27 +58,6 @@ popen file args minput =
|
|||||||
case exitCode of
|
case exitCode of
|
||||||
ExitFailure code
|
ExitFailure code
|
||||||
| null errput -> let errMsg = file ++ ": failed with error code " ++ show code
|
| null errput -> let errMsg = file ++ ": failed with error code " ++ show code
|
||||||
in return ([],errMsg,error errMsg)
|
in return ([],errMsg,False,error errMsg)
|
||||||
_ -> return (output,errput,pid)
|
| otherwise -> return ([],errput,False,error errput)
|
||||||
|
_ -> return (output,errput,True,pid)
|
||||||
#else
|
|
||||||
|
|
||||||
--
|
|
||||||
-- catch so that we can deal with forkProcess failing gracefully. and
|
|
||||||
-- getProcessStatus is needed so as not to get a bunch of zombies,
|
|
||||||
-- leading to forkProcess failing.
|
|
||||||
--
|
|
||||||
-- Large amounts of input will cause problems with blocking as we wait
|
|
||||||
-- on the process to finish. Make sure no lambdabot processes will
|
|
||||||
-- generate 1000s of lines of output.
|
|
||||||
--
|
|
||||||
popen :: FilePath -> [String] -> Maybe String -> IO (String,String,P.ProcessID)
|
|
||||||
popen f s m =
|
|
||||||
E.handle (\e -> return ([], show (e::IOException), error $ show e )) $ do
|
|
||||||
x@(_,_,pid) <- P.popen f s m
|
|
||||||
b <- P.getProcessStatus True False pid -- wait
|
|
||||||
return $ case b of
|
|
||||||
Nothing -> ([], "process has disappeared", pid)
|
|
||||||
_ -> x
|
|
||||||
|
|
||||||
#endif
|
|
||||||
|
Loading…
x
Reference in New Issue
Block a user