Refactored build of executable and library.

1 files changed, 45 insertions, 0 deletions

diff --git a/lib/ProcessUtils.hs b/lib/ProcessUtils.hs
new file mode 100644
index 0000000..4e3ac38
--- /dev/null
+++ b/lib/ProcessUtils.hs
@@ -0,0 +1,45 @@
+module ProcessUtils
+    ( ExitCode(ExitFailure,ExitSuccess)
+    , systemEnv
+    ) where
+
+import GHC.IO.Exception ( ioException, IOErrorType(..) )
+import System.Process
+import System.Posix.Signals
+import System.Process.Internals (runGenProcess_,defaultSignal)
+import System.Environment
+import Data.Maybe ( isNothing )
+import System.IO.Error ( mkIOError, ioeSetErrorString ) 
+import System.Exit ( ExitCode(..) )
+
+
+-- | systemEnv
+-- This is like System.Process.system except that it lets you set
+-- some environment variables.
+systemEnv :: [(String, String)] -> String -> IO ExitCode
+systemEnv _    ""  = 
+    ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command")
+systemEnv vars cmd = do
+    env0 <- getEnvironment
+    let env1 = filter (isNothing . flip lookup vars . fst) env0
+        env = vars ++ env1
+    syncProcess "system" $ (shell cmd) {env=Just env}
+ where
+    -- This is a non-exported function from System.Process
+    syncProcess fun c = do
+      -- The POSIX version of system needs to do some manipulation of signal
+      -- handlers.  Since we're going to be synchronously waiting for the child,
+      -- we want to ignore ^C in the parent, but handle it the default way
+      -- in the child (using SIG_DFL isn't really correct, it should be the
+      -- original signal handler, but the GHC RTS will have already set up
+      -- its own handler and we don't want to use that).
+      old_int  <- installHandler sigINT  Ignore Nothing
+      old_quit <- installHandler sigQUIT Ignore Nothing
+      (_,_,_,p) <- runGenProcess_ fun c
+            (Just defaultSignal) (Just defaultSignal)
+      r <- waitForProcess p
+      _ <- installHandler sigINT  old_int Nothing
+      _ <- installHandler sigQUIT old_quit Nothing
+      return r
+
+