[Gtk2hs-commit] (main branch): Add demon for cross-process embedded.

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

Sat Nov 21 12:12:21 EST 2009  Andy Stewart <laz...@gm...>
  * Add demon for cross-process embedded.
  Ignore-this: c8d6723ea37ea41bf293ab835a64ab4c

    adddir ./demo/embbeded
    addfile ./demo/embbeded/Embedded.hs
    hunk ./demo/embbeded/Embedded.hs 1
    +-- Use GtkSocket and GtkPlug for cross-process embedded.
    +-- Just startup program, press 'Alt-m' to new editor, press `Alt-n` to new terminal.
    +-- And those plug widget (editor, terminal) running in child-process, [_$_]
    +-- so program won't crash when child-process throw un-catch exception.
    +
    +module Main where
    +
    +import System.Posix.Process
    +import System.Environment
    +import System.Directory
    +import System.FilePath ((</>))
    +import Control.Monad
    +
    +import Event
    +import Key
    +
    +import Graphics.UI.Gtk
    +import Graphics.UI.Gtk.General.Structs
    +import Graphics.UI.Gtk.Vte.Vte
    +
    +import qualified Graphics.UI.Gtk.Gdk.Events as E
    +
    +data PlugType = PlugEditor
    +              | PlugTerminal
    +              deriving (Eq, Ord, Show, Read)
    +
    +-- | Main.
    +main :: IO ()
    +main = do
    +  -- Init main.
    +  initGUI
    +
    +  -- Get program arguments.
    +  args <- getArgs
    +
    +  case length args of
    +    -- Entry socket main when no arguments.
    +    0 -> socketMain [_$_]
    +
    +    -- Entry plug main when have two arguments.
    +    2 -> do
    +      let typeArg = read (head args) :: PlugType -- get Plug type
    +          idArg   = toNativeWindowId $ read (last args) :: NativeWindowId -- get GtkSocket id
    +
    +      case typeArg of
    +        PlugEditor   -> editorPlugMain idArg   -- entry eidtor plug main
    +        PlugTerminal -> terminalPlugMain idArg -- entry terminal plug main
    +
    +    -- Otherwise just output error and exit.
    +    _ -> putStrLn "Wrong program arguments."
    +  [_$_]
    +-- | Handle key press.
    +handleKeyPress :: E.Event -> Notebook -> IO Bool
    +handleKeyPress ev notebook = [_$_]
    +    case eventTransform ev of
    +      Nothing -> return False
    +      Just e  -> [_$_]
    +          case eventGetName e of
    +            "M-m" -> forkPlugProcess notebook PlugEditor "Editor" >> return True
    +            "M-n" -> forkPlugProcess notebook PlugTerminal "Terminal" >> return True
    +            _     -> return False
    +
    +-- | Fork plug process.
    +forkPlugProcess :: Notebook -> PlugType -> String -> IO ()
    +forkPlugProcess notebook plugType tabName = do
    +  -- Create new GtkSocket.
    +  socket <- socketNew
    +  widgetShow socket                          -- must show before add GtkSocekt to container
    +  notebookAppendPage notebook socket tabName -- add to GtkSocekt notebook
    +  id <- socketGetId socket                    -- get GtkSocket id
    +
    +  -- Fork process to add GtkPlug into GtkSocekt. [_$_]
    +  forkProcess (do
    +                path <- liftM2 (</>) getCurrentDirectory getProgName -- get program full path
    +                executeFile path False [show plugType, show $ fromNativeWindowId id] Nothing)
    +  return ()
    +
    +-- | GtkSocekt main.
    +socketMain :: IO ()  [_$_]
    +socketMain = do
    +  -- Output message.
    +  pid <- getProcessID
    +  putStrLn $ "Running in socket process : " ++ show pid
    +
    +  -- Create top-level window.
    +  window <- windowNew
    +  windowFullscreen window
    +  window `onDestroy` mainQuit
    +
    +  -- Create notebook to contain GtkSocekt.
    +  notebook <- notebookNew
    +  window `containerAdd` notebook
    +
    +  -- Handle key press.
    +  window `onKeyPress` (\event -> handleKeyPress event notebook)
    +
    +  widgetShowAll window
    +
    +  mainGUI
    +
    +-- | Editor plug main.
    +editorPlugMain :: NativeWindowId -> IO ()
    +editorPlugMain id = do
    +  -- Create editor.
    +  textView <- textViewNew
    +  textBuffer <- textViewGetBuffer textView
    +  textBufferSetText textBuffer $ show id
    +
    +  plugWrap id textView
    +
    +-- | Terminal plug main.
    +terminalPlugMain :: NativeWindowId -> IO ()
    +terminalPlugMain id = do
    +  -- Create terminal.
    +  terminal <- terminalNew
    +  terminalForkCommand terminal Nothing Nothing Nothing Nothing False False False
    +
    +  plugWrap id terminal
    +
    +-- | Plug wrap function.
    +plugWrap :: WidgetClass widget => NativeWindowId -> widget -> IO ()
    +plugWrap id widget = do
    +  -- Output message.
    +  pid <- getProcessID
    +  putStrLn $ "Running in plug process : " ++ show pid
    +
    +  -- Create GtkPlug with GtkSocekt id.
    +  plug <- plugNew $ Just id
    +  plug `onDestroy` mainQuit
    +  [_$_]
    +  -- Add widget to GtkPlug.
    +  scrolledWindow <- scrolledWindowNew Nothing Nothing
    +  scrolledWindow `containerAdd` widget
    +  plug `containerAdd` scrolledWindow
    +
    +  widgetShowAll plug  [_$_]
    +
    +  mainGUI
    +
    addfile ./demo/embbeded/Event.hs
    hunk ./demo/embbeded/Event.hs 1
    +module Event where
    +
    +import Data.List
    +
    +import Key
    +
    +import qualified Graphics.UI.Gtk.Gdk.Events as E
    +
    +-- | The advanced event.
    +data Event = Event Key [Modifier] deriving (Eq)
    +
    +-- | Output event describe.
    +eventGetName :: Event -> String
    +eventGetName (Event key mods) = concatMap ((++ "-") . keyModifier) mods ++ keyDescribe key
    +  where [_$_]
    +    -- Key describe
    +    keyDescribe (KFun i) = 'F' : show i -- Function key (F1, F2, F3... etc.)
    +    keyDescribe (KASCII c) = [c]        -- Character key ('A', 'B', 'C'... etc.)
    +    keyDescribe k = tail $ show k       -- Control key (Ctrl, Alt, Shift... etc.)
    +    -- Key modifier
    +    keyModifier m = [show m !! 1]
    +
    +-- | Transform basic event to advanced event.    [_$_]
    +eventTransform :: E.Event -> Maybe Event
    +eventTransform (E.Key {E.eventKeyName         = keyName, [_$_]
    +                       E.eventKeyChar         = keyChar,
    +                       E.eventModifier        = keyModifier})
    +    = fmap (\k -> Event k [_$_]
    +                 (nub $ sort $ (if isShift [_$_]
    +                                then filter (/= MShift) [_$_]
    +                                else id)                          -- key
    +                 $ concatMap eventTransformModifier keyModifier)) -- modifier
    +      key
    +      where
    +        (key, isShift) =
    +            case keyChar of
    +              Just c -> (Just $ KASCII c, True)     -- character key
    +              Nothing -> (keyLookup keyName, False) -- other key
    +eventTransform _ = Nothing
    +
    +-- | Transform event modifier.
    +eventTransformModifier E.Control = [MCtrl]
    +eventTransformModifier E.Alt     = [MMeta]
    +eventTransformModifier E.Shift   = [MShift]
    +eventTransformModifier E.Super   = [MSuper]
    +eventTransformModifier _         = [] -- Use underscore so we don't depend on the differences between gtk2hs versions
    addfile ./demo/embbeded/Key.hs
    hunk ./demo/embbeded/Key.hs 1
    +module Key where
    +
    +import Data.Map (Map)
    +
    +import Text.Regex.TDFA
    +import Data.Maybe
    +
    +import qualified Data.Map as M
    +
    +-- | The key modifier for transform event.
    +data Modifier = MShift | MCtrl | MMeta | MSuper
    +                deriving (Show,Eq,Ord)
    +
    +-- | The key type.
    +data Key = KEsc | KFun Int | KPrtScr | KPause | KASCII Char | KBS | KIns
    +         | KHome | KEnd | KPageUp | KPageDown | KDel | KNP5 | KUp | KMenu
    +         | KLeft | KDown | KRight | KEnter | KTab [_$_]
    +           deriving (Eq,Show,Ord)
    +
    +type Keytable = Map String Key
    +
    +-- | Map GTK long names to Keys
    +keyTable :: Keytable
    +keyTable = M.fromList
    +    [("Down",         KDown)
    +    ,("Up",           KUp)
    +    ,("Left",         KLeft)
    +    ,("Right",        KRight)
    +    ,("Home",         KHome)
    +    ,("End",          KEnd)
    +    ,("BackSpace",    KBS)
    +    ,("Delete",       KDel)
    +    ,("Page_Up",      KPageUp)
    +    ,("Page_Down",    KPageDown)
    +    ,("Insert",       KIns)
    +    ,("Escape",       KEsc)
    +    ,("Return",       KEnter)
    +    ,("Tab",          KTab)
    +    ,("ISO_Left_Tab", KTab)]
    +
    +-- | Lookup key name from key table.
    +keyLookup :: String -> Maybe Key
    +keyLookup keyName = [_$_]
    +  case key of
    +    Just k  -> Just k             -- control key
    +    Nothing -> if keyName =~ "^F[0-9]+$" :: Bool [_$_]
    +              then Just $ KFun (read (tail keyName) :: Int) -- function key
    +              else Nothing                                 -- other key
    +  where
    +    key = M.lookup keyName keyTable
    addfile ./demo/embbeded/Makefile
    hunk ./demo/embbeded/Makefile 1
    +
    +PROG  = Embedded
    +SOURCES = Embedded.hs Event.hs Key.hs
    +
    +$(PROG) : $(SOURCES)
    +	$(HC) --make $< -o $@ $(HCFLAGS) -XForeignFunctionInterface
    +
    +clean:
    +	rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
    +
    +HC=ghc