Merge pull request #11 from noughtmare/master

Pretty ugly fix for #10

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

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?
+    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

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 [])
+        (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
 
@@ -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)
+                           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