From 9c5017edee5590e1691c67b742b699f29b995f46 Mon Sep 17 00:00:00 2001
From: Jaro Reinders <jaro.reinders@gmail.com>
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)