[Gtk2hs-commit] (main branch): Add WebKit demo.

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

Sat Mar 20 11:17:26 EDT 2010  Andy Stewart <laz...@gm...>
  * Add WebKit demo.
  Ignore-this: cddf99434ea4b04a41e1f13c3b91d177

    adddir ./demo/webkit
    addfile ./demo/webkit/Makefile
    hunk ./demo/webkit/Makefile 1
    +
    +PROGS  = webkit
    +SOURCES = Webkit.hs
    +
    +all : $(PROGS)
    +
    +webkit : Webkit.hs
    +	$(HC) --make $< -o $@ $(HCFLAGS)
    +
    +clean:
    +	rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
    +
    +HC=ghc
    addfile ./demo/webkit/Webkit.hs
    hunk ./demo/webkit/Webkit.hs 1
    +-- | WebKit browser demo.
    +--  Author      :  Andy Stewart
    +--  Copyright   :  (c) 2010 Andy Stewart <laz...@gm...>
    +
    +-- | This simple browser base on WebKit API.
    +-- For simple, i just make all link open in current window.
    +-- Of course, you can integrate signal `createWebView` with `notebook`
    +-- to build multi-tab browser.
    +--
    +-- You can click right-button for forward or backward page.
    +--
    +-- Usage:
    +--      webkit [uri]
    +--
    +module Main where
    +
    +import Graphics.UI.Gtk
    +import Graphics.UI.Gtk.General.Structs
    +import Graphics.UI.Gtk.WebKit.WebView
    +import Graphics.UI.Gtk.WebKit.WebFrame
    +
    +import System.Process
    +import System.Environment [_$_]
    +
    +-- | Main entry.
    +main :: IO ()
    +main = do
    +  -- Get program arguments.
    +  args <- getArgs
    +  case args of
    +    -- Display help
    +    ["--help"] -> do
    +       putStrLn $ "Welcome to Gtk2hs WebKit demo. :)\n\n" ++ [_$_]
    +                  "Usage: webkit [uri]\n\n" ++
    +                  "  -- Gtk2hs Team"
    +    -- Start program.
    +    [arg]    -> browser arg                     -- entry user input url
    +    _        -> browser "http://www.google.com" -- entry default url
    +
    +-- | Internal browser fucntion.
    +browser :: String -> IO ()
    +browser url = do
    +  -- Init.
    +  initGUI
    +  [_$_]
    +  -- 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 WebKit view.
    +  webView <- webViewNew
    +  [_$_]
    +  -- Create window box.
    +  winBox <- vBoxNew False 0
    +  [_$_]
    +  -- Create address bar.
    +  addressBar <- entryNew
    +
    +  -- Create scroll window.
    +  scrollWin <- scrolledWindowNew Nothing Nothing
    +
    +  -- Load uri.
    +  webViewLoadUri webView url
    +  entrySetText addressBar url
    +
    +  -- Open uri when user press `return` at address bar.
    +  onEntryActivate addressBar $ do
    +    uri <- entryGetText addressBar -- get uri from address bar
    +    webViewLoadUri webView uri    -- load new uri
    +
    +  -- Add current uri to address bar when load start.
    +  webView `on` loadStarted $ \frame -> do
    +    currentUri <- webFrameGetUri frame
    +    case currentUri of
    +         Just uri -> entrySetText addressBar uri
    +         Nothing  -> return ()
    +
    +  -- Open all link in current window.
    +  webView `on` createWebView $ \frame -> do
    +    newUri <- webFrameGetUri frame
    +    case newUri of
    +      Just uri -> webViewLoadUri webView uri
    +      Nothing  -> return ()
    +    return webView
    +
    +  -- Connect and show.
    +  boxPackStart winBox addressBar PackNatural 0
    +  boxPackStart winBox scrollWin PackGrow 0
    +  window `containerAdd` winBox
    +  scrollWin `containerAdd` webView
    +  window `onDestroy` mainQuit
    +  widgetShowAll window
    +
    +  mainGUI