Embedded.hs

-- Use GtkSocket and GtkPlug for cross-process embedded.
-- Just startup program, press 'm' to create tab with new button.
-- Click button for hang to simulate plug hanging process,
-- but socket process still running, can switch to other tab.

module Main where

import System.Process
import System.Environment
import System.Directory
import System.FilePath ((</>))
import Control.Monad
import Control.Monad.Trans
import Control.Concurrent

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Gdk.DrawWindow
import Graphics.UI.Gtk.Gdk.EventM

-- | Main.
main :: IO ()
main = do
  -- Get program arguments.
  args <- getArgs

  case args of
    -- Entry plug main when have two arguments.
    [id] -> plugMain (toNativeWindowId $ read id :: NativeWindowId) -- get GtkSocket id
    -- Othersise entry socket main when no arguments.
    _ -> socketMain

-- | GtkSocekt main.
socketMain :: IO ()
socketMain = do
  initGUI

  -- Create top-level window.
  window <- windowNew
  windowSetPosition window WinPosCenter
  windowSetDefaultSize window 600 400
  windowSetTitle window "Press `m` to new tab, press `q` exit."
  window `onDestroy` mainQuit

  -- Create notebook to contain GtkSocekt.
  notebook <- notebookNew
  window `containerAdd` notebook

  -- Handle key press.
  window `on` keyPressEvent $ tryEvent $ do
    keyName <- eventKeyName
    liftIO $
      case keyName of
        "m" -> do
               -- Create new GtkSocket.
               socket <- socketNew
               widgetShow socket                          -- must show before add GtkSocekt to container
               notebookAppendPage notebook socket "Tab"   -- add to GtkSocekt notebook
               id <- socketGetId socket                    -- get GtkSocket id

               -- Fork process to add GtkPlug into GtkSocekt.
               path <- liftM2 (</>) getCurrentDirectory getProgName -- get program full path
               runCommand $ path ++ " " ++ (show $ fromNativeWindowId id) -- don't use `forkProcess`
               return ()
        "q" -> mainQuit          -- quit

  widgetShowAll window

  mainGUI

-- | GtkPlug main.
plugMain :: NativeWindowId -> IO ()
plugMain id = do
  initGUI

  plug <- plugNew $ Just id
  plug `onDestroy` mainQuit

  button <- buttonNewWithLabel "Click me to hang."
  plug `containerAdd` button

  -- Simulate a plugin hanging to see if it blocks the outer process.
  button `onClicked` threadDelay 5000000

  widgetShowAll plug

  mainGUI