avoid hang when terminal emulator fails to run debug-me

1 files changed, 13 insertions, 8 deletions

diff --git a/ControlWindow.hs b/ControlWindow.hs
index 2540640..4f806c9 100644
--- a/ControlWindow.hs
+++ b/ControlWindow.hs
@@ -69,15 +69,20 @@ openControlWindow = do
 	_ <- async $ serveControlSocket soc ichan ochan
 	myexe <- getExecutablePath
 	mproc <- runInVirtualTerminal winDesc myexe ["--control"]
+	let cannotrun = do
+		putStrLn "You need to open another shell prompt, and run: debug-me --control"
+		return (ichan, ochan)
 	case mproc of
-		Nothing -> putStrLn "You need to open another shell prompt, and run: debug-me --control"
-		Just p -> void $ createProcess p
-	-- Wait for message from control process.
-	v <- atomically $ readTMChan ochan
-	case v of
-		Just ControlWindowOpened -> return ()
-		_ -> error "unexpected message from control process"
-	return (ichan, ochan)
+		Nothing -> cannotrun
+		Just p -> do
+			(_, _, _, pid) <- createProcess p
+			-- Wait for message from control process.
+			v <- atomically (readTMChan ochan)
+				`race` waitForProcess pid
+			case v of
+				Left (Just ControlWindowOpened) -> return (ichan, ochan)
+				Left _ -> error "unexpected message from control process"
+				Right _ -> cannotrun
 
 type Prompt = ()
 type Response = String