From 9c5017edee5590e1691c67b742b699f29b995f46 Mon Sep 17 00:00:00 2001 From: Jaro Reinders Date: Tue, 13 Aug 2019 16:23:23 +0200 Subject: [PATCH] pretty ugly fix #10 --- src/System/Plugins/Load.hs | 12 +++++----- src/System/Plugins/Make.hs | 14 ++++++------ src/System/Plugins/Process.hs | 43 +++++++---------------------------- 3 files changed, 21 insertions(+), 48 deletions(-) diff --git a/src/System/Plugins/Load.hs b/src/System/Plugins/Load.hs index a824efc..d138999 100644 --- a/src/System/Plugins/Load.hs +++ b/src/System/Plugins/Load.hs @@ -260,11 +260,11 @@ pdynload object incpaths pkgconfs ty sym = do #if DEBUG putStr "Checking types ... " >> hFlush stdout #endif - errors <- unify object incpaths [] ty sym + (errors, success) <- unify object incpaths [] ty sym #if DEBUG putStrLn "done" #endif - if null errors + if success then load object incpaths pkgconfs sym else return $ LoadFailure errors @@ -284,11 +284,11 @@ pdynload_ object incpaths pkgconfs args ty sym = do #if DEBUG putStr "Checking types ... " >> hFlush stdout #endif - errors <- unify object incpaths args ty sym + (errors, success) <- unify object incpaths args ty sym #if DEBUG putStrLn "done" #endif - if null errors + if success then load object incpaths pkgconfs sym else return $ LoadFailure errors @@ -317,9 +317,9 @@ unify obj incs args ty sym = do 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] - return e + return (e, success) where -- fix up hierarchical names diff --git a/src/System/Plugins/Make.hs b/src/System/Plugins/Make.hs index 0017844..056b33a 100644 --- a/src/System/Plugins/Make.hs +++ b/src/System/Plugins/Make.hs @@ -269,11 +269,11 @@ rawMake src args docheck = do #if DEBUG putStr "Compiling object ... " >> hFlush stdout #endif - err <- build src obj args + (err, success) <- build src obj args #if DEBUG putStrLn "done" #endif - return $ if null err + return $ if success then MakeSuccess ReComp obj else MakeFailure err } @@ -287,7 +287,7 @@ rawMake src args docheck = do build :: FilePath -- ^ path to .hs source -> FilePath -- ^ path to object file -> [String] -- ^ any extra cmd line flags - -> IO [String] + -> IO ([String], Bool) build src obj extra_opts = do @@ -306,12 +306,12 @@ build src obj extra_opts = do putStr $ show $ ghc : flags #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 - return $ if not obj_exists && null err -- no errors, but no object? - then ["Compiled, but didn't create object file `"++obj++"'!"] - else err + return $ if not obj_exists && success + then (["Compiled, but didn't create object file `"++obj++"'!"], success) + else (err, success) -- --------------------------------------------------------------------- -- | Merge to source files into a temporary file. If we've tried to diff --git a/src/System/Plugins/Process.hs b/src/System/Plugins/Process.hs index 62a6f04..e1aa3b5 100644 --- a/src/System/Plugins/Process.hs +++ b/src/System/Plugins/Process.hs @@ -7,25 +7,19 @@ module System.Plugins.Process (exec, popen) where import System.Exit -#if __GLASGOW_HASKELL__ >= 604 import System.IO import System.Process import Control.Concurrent (forkIO) -#else -import qualified Posix as P -#endif import qualified Control.Exception as E -- -- 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 - (a,b,_) <- popen f as (Just []) - return (lines a, lines b) - -#if __GLASGOW_HASKELL__ >= 604 + (a,b,c,_) <- popen f as (Just []) + return (lines a, lines b,c) type ProcessID = ProcessHandle @@ -37,9 +31,9 @@ type ProcessID = ProcessHandle -- Posix.popen doesn't have this problem, so maybe we can reproduce its -- 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 = - 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 @@ -64,27 +58,6 @@ popen file args minput = case exitCode of ExitFailure code | null errput -> let errMsg = file ++ ": failed with error code " ++ show code - in return ([],errMsg,error errMsg) - _ -> return (output,errput,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 + in return ([],errMsg,False,error errMsg) + | otherwise -> return ([],errput,False,error errput) + _ -> return (output,errput,True,pid)