Sat Mar 13 08:10:51 EST 2010 Andy Stewart <laz...@gm...>
* Update embedded demo (looks uzbl demo lost when merge patchs).
Ignore-this: ff89b127ee7e9a526d4c3a252bbca9bb
hunk ./demo/embbeded/Embedded.hs 1
--- |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. [_$_]
---
--- Note:
---
--- Don't use `forkProcess` in gtk2hs!
--- Because `forkProcess` haven't any protect when spawn process, [_$_]
--- so you will got two processes *race condition*, when those two
--- process access same resource will crash your program.
--- Solution is use `runProcess` or `runCommand` instead, [_$_]
--- Because those functions add MVar to make sure two processes won't
--- get *race condition* problem.
---
-
-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.General.Structs
-import Graphics.UI.Gtk.Gdk.EventM
-
--- | Main.
-main :: IO ()
-main = do
- -- Init main.
- initGUI
-
- -- 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
- -- 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
- 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
rmfile ./demo/embbeded/Embedded.hs
hunk ./demo/embbeded/Makefile 1
-PROGS = Embedded Uzbl
-SOURCES = Embedded.hs Uzbl.hs
-
-all : $(PROGS)
-
-Embedded : Embedded.hs
- $(HC_RULE)
-
-Uzbl : Uzbl.hs
- $(HC_RULE)
-
-HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
-
-HC=ghc
rmfile ./demo/embbeded/Makefile
rmdir ./demo/embbeded
|
