[Gtk2hs-commit] (main branch): Add missing demo/embedded directory, i don't know how to remove it. Sorry!

[Andy S. <And...@co...>]

Sat Mar 13 11:11:57 EST 2010  Andy Stewart <laz...@gm...>
  * Add missing demo/embedded directory, i don't know how to remove it. Sorry!
  Ignore-this: 87c60d1b7f85e37d955dddcf69ca4cf2

    adddir ./demo/embedded
    addfile ./demo/embedded/Embedded.hs
    hunk ./demo/embedded/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. [_$_]
    +
    +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
    +  -- 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
    addfile ./demo/embedded/Makefile
    hunk ./demo/embedded/Makefile 1
    +
    +PROGS  = Embedded Uzbl
    +SOURCES = Embedded.hs Uzbl.hs
    +
    +all : $(PROGS)
    +
    +Embedded : Embedded.hs
    +	$(HC) --make $< -o $@ $(HCFLAGS)
    +
    +Uzbl : Uzbl.hs
    +	$(HC) --make $< -o $@ $(HCFLAGS)
    +
    +clean:
    +	rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
    +
    +HC=ghc
    addfile ./demo/embedded/Uzbl.hs
    hunk ./demo/embedded/Uzbl.hs 1
    +-- | This is program use uzbl embedded in window to render webpage.
    +-- Just simple model demo for view, haven't handle event or else. [_$_]
    +--
    +-- You need install uzbl (git clone git://github.com/Dieterbe/uzbl.git) first.
    +-- [_$_]
    +-- How to use: [_$_]
    +-- ./Uzbl       default open Google page.
    +-- ./Uzbl url   will open url you input
    +--
    +module Main where
    +
    +import Graphics.UI.Gtk
    +import Graphics.UI.Gtk.General.Structs
    +import System.Process
    +import System.Environment [_$_]
    +
    +main :: IO ()
    +main = do
    +  -- Init.
    +  initGUI
    +  [_$_]
    +  -- Get program arguments.
    +  args <- getArgs
    +  let url = case args of
    +              [arg] -> arg                      -- get user input url
    +              _     ->  "http://www.google.com" -- set default url
    +
    +  -- Create window.
    +  window <- windowNew
    +  windowSetDefaultSize window 900 600
    +  windowSetPosition window WinPosCenter
    +  windowSetOpacity window 0.8   -- this function need window-manager support Alpha channel in X11
    +  [_$_]
    +  -- Create socket.
    +  socket <- socketNew
    +  widgetShow socket             -- must show before add to parent
    +  window `containerAdd` socket
    +
    +  -- Get socket id.
    +  socketId <- fmap (show . fromNativeWindowId) $ socketGetId socket
    +
    +  -- Start uzbl-core process.
    +  runCommand $ "uzbl-core -s " ++ socketId ++ " -u " ++ url
    +
    +  -- Show.
    +  window `onDestroy` mainQuit
    +  widgetShowAll window
    +
    +  mainGUI