packages feed

spike (empty) → 0.1

raw patch · 11 files changed

+920/−0 lines, 11 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, filepath, gtk, mtl, process, rosezipper, stm, webkit

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Krzysztof Skrzętnicki++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Krzysztof Skrzętnicki nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/cbits.c view
@@ -0,0 +1,20 @@+#include <libsoup/soup.h>+#include <libsoup/soup-gnome.h>+#include <webkit/webkit.h>++#include <gtk/gtk.h>+#include <glib/gi18n.h>+#include <libsoup/soup.h>+#include <webkit/webkit.h>++void spike_setup_webkit_globals(char * web_database_path, char * cookie_jar_path)+{+  //eg. /tmp/spike.webkit.db+  webkit_set_web_database_directory_path(web_database_path);++  +  SoupSession * ses = webkit_get_default_session();+  //eg. /tmp/spike.webkit.cookie.db+  SoupCookieJar * jar = soup_cookie_jar_sqlite_new(cookie_jar_path, 0);+  soup_session_add_feature( ses, SOUP_SESSION_FEATURE (jar));+}
+ spike.cabal view
@@ -0,0 +1,26 @@+Name:                spike+Version:             0.1+Synopsis:            Experimental web browser+Description:         Experimental web browser based on WebKit-Gtk++License:             BSD3+License-file:        LICENSE+Author:              Krzysztof Skrzętnicki+Maintainer:          gtener@gmail.com+Category:            Web+Build-type:          Simple+Cabal-version:       >=1.6+Homepage:            http://github.com/Tener/spike++Source-repository head+  type:              git+  location:          git://github.com/Tener/spike.git+++Executable spike+  Main-is:           spike.hs+  Other-modules:     Utils, VisualBrowseTree, Datatypes, Graphs, CFunctions, NotebookSimple+  Hs-source-dirs:    src+  Build-depends:     webkit == 0.12.*, containers, gtk, base == 4.*, stm, mtl > 2, rosezipper, process, directory, filepath+  Ghc-options:       -rtsopts+  C-sources:         cbits/cbits.c+  pkgconfig-depends: libsoup-gnome-2.4
+ src/CFunctions.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE PackageImports, FlexibleInstances, DoRec, ForeignFunctionInterface #-}++module CFunctions(spikeSetupWebkitGlobals) where++import Foreign+import Foreign.C++foreign import ccall "spike_setup_webkit_globals" spike_setup_webkit_globals :: CString -> CString -> IO ()++spikeSetupWebkitGlobals arg1 arg2 =+  withCString arg1 $ \ arg1' -> +  withCString arg2 $ \ arg2' -> spike_setup_webkit_globals arg1' arg2'
+ src/Datatypes.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE PackageImports, FlexibleInstances, DoRec, ForeignFunctionInterface #-}+module Datatypes where++import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.WebNavigationAction+import System.IO.Unsafe+import Graphics.UI.Gtk+import Control.Concurrent.STM+import Data.Tree++data History = Hist { hiNow :: String, hiPrev :: [String], hiNext :: [String] } deriving Show++data Page = Page { pgWeb :: WebView, pgWidget :: Widget, pgHistory :: TVar History }++instance Show Page where+    show pg = "Page { pgWeb=?, pgWidget=?, pgHistory=" ++ show (unsafeDupablePerformIO (readTVarIO (pgHistory pg))) ++ "}"++instance Eq Page where+    p1 == p2 = pgWidget p1 == pgWidget p2++type BrowseTree = Forest Page+type BrowseTreeState = TVar BrowseTree++-- wrapper newtype to avoid orphan instances+newtype MyShow a = MyShow a+instance Show (MyShow NavigationReason) where+    show (MyShow WebNavigationReasonLinkClicked    )  = "WebNavigationReasonLinkClicked"+    show (MyShow WebNavigationReasonFormSubmitted  )  = "WebNavigationReasonFormSubmitted"+    show (MyShow WebNavigationReasonBackForward    )  = "WebNavigationReasonBackForward"+    show (MyShow WebNavigationReasonReload         )  = "WebNavigationReasonReload"+    show (MyShow WebNavigationReasonFormResubmitted)  = "WebNavigationReasonFormResubmitted"+    show (MyShow WebNavigationReasonOther          )  = "WebNavigationReasonOther"
+ src/Graphs.hs view
@@ -0,0 +1,28 @@+module Graphs where++import Data.Tree+import Data.Tree.Zipper+import Data.Graph.Inductive++treeToGraph :: (Graph gr) => Tree a -> gr a ()+treeToGraph tr = labelTree tr [1..]++labelTree tr = let tr1 = fmap tr (\x -> (x,0))+                   tp1 = fromTree tr1+                   tp2 = go 0 tp1+                   tr2 = toTree tp2+                         ++                   go ix tp = let tp' = modifyLabel (\(l,_) -> (l,ix)) tp in+                                ++                   go tp = case next tp of+                             Nothing -> firstChild tp+                             Just tpN -> go tpN++labelTree (Node a xs) (y:ys) = let (xs',ys') = labelTree' xs ys+                                   n' = Node (a,y) xs'+                               in+                                   (n',xs')++labelTree' lst labs =
+ src/NotebookSimple.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE ViewPatterns #-}++-- this module is a simple reimplementation of GTK Notebook widget.+-- I needed to be able to change the list of pages without receving a signal from it.+module NotebookSimple where++import Graphics.UI.Gtk+import Control.Concurrent+import Control.Concurrent.STM++import Data.List (elemIndex)++import Utils+import Datatypes++data NotebookSimple = NotebookSimple { ns_tabs :: HBox+                                     , ns_widget :: Widget+                                     , ns_pages :: TVar [Page]+                                     , ns_currentPage :: TVar (Maybe Int)+                                     , ns_refresh :: IO ()+                                     }++newScrolledWindowWithViewPort :: WidgetClass child => child -> IO ScrolledWindow+newScrolledWindowWithViewPort child = do+  sw <- scrolledWindowNew Nothing Nothing+  scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic+  scrolledWindowAddWithViewport sw child+  (wx,wy) <- widgetGetSizeRequest child+  widgetSetSizeRequest sw (wx+5) (wy+5)+  return sw++notebookSimpleNew :: (Page -> IO ()) -> IO NotebookSimple+notebookSimpleNew focusOnPage = do+  buttonsBox <- hBoxNew False 1+  contentBox <- hBoxNew False 1+  vbox <- vBoxNew False 1++  widgetSetSizeRequest buttonsBox (-1) 40++  (\sw -> boxPackStart vbox sw PackNatural 1) =<< newScrolledWindowWithViewPort buttonsBox+  boxPackStart vbox contentBox PackGrow 1++  widgetShowAll vbox++  pgs <- newTVarIO [] :: IO (TVar [Page])+  curr <- newTVarIO Nothing++  let updateButtons = postGUIAsync $ do+         pages <- readTVarIO pgs+         listPagesBox focusOnPage pages buttonsBox ++      updatePage = do +        wg <- getCurrentWidget+        case wg of+          Just wg' -> postGUIAsync (do+                                     containerForeach contentBox (containerRemove contentBox)+                                     set contentBox [ containerChild := (pgWidget wg') ] >> widgetShowAll vbox)+          Nothing -> print "strange stuff."++      getCurrentWidget = do+         c <- readTVarIO curr+         p <- readTVarIO pgs+         case c of+           Nothing -> return Nothing+           Just c' -> return (if c' < length p then Just (p !! c') else Nothing)++  let watchdog page = do+         page' <- waitTVarChangeFrom page curr+         updatePage+         watchdog page'++  let watchdog2 pages = do+         pages' <- waitTVarChangeFrom pages pgs+         updateButtons+         watchdog2 pages'++  forkIO (watchdog2 =<< readTVarIO pgs)+  forkIO (watchdog =<< readTVarIO curr)++  let updateAll = updateButtons >> updatePage+  return (NotebookSimple { ns_tabs = contentBox+                         , ns_widget = (toWidget vbox)+                         , ns_pages = pgs+                         , ns_currentPage = curr+                         , ns_refresh = updateAll })++notebookSimpleAddPage :: NotebookSimple -> Page -> IO ()+notebookSimpleAddPage ns@(ns_pages -> pages) page = do+  atomically $ do+    pages' <- readTVar pages+    writeTVar pages (pages' ++ [page])+  notebookSimpleSelectPageIfNone ns++notebookSimpleSelectPage :: NotebookSimple -> Page -> IO ()+notebookSimpleSelectPage ns page = do+  atomically $ do+    current <- readTVar (ns_currentPage ns)+    pages <- readTVar (ns_pages ns)+    writeTVar (ns_currentPage ns) (elemIndex page pages)+  +notebookSimpleSelectPageIfNone :: NotebookSimple -> IO ()+notebookSimpleSelectPageIfNone ns = do+  atomically $ do+    current <- readTVar (ns_currentPage ns)+    case current of+      Nothing -> writeTVar (ns_currentPage ns) (Just 0)+      Just _ -> return ()+++-- | list pages in a box+-- listPagesBox :: (BoxClass box) => [Page] -> box -> IO ()+listPagesBox :: BoxClass box => (Page -> IO a) -> [Page] -> box -> IO ()+listPagesBox focusOnPage pages box = do+  containerForeach box (containerRemove box)+  mapM_ (\p -> do+           title <- getPageTitle p+           l <- labelNew (Just title) -- TODO: use AccelLabel and shortcuts for specific pages+           labelSetEllipsize l EllipsizeEnd+           labelSetWidthChars l 20+           labelSetSingleLineMode l True++           b <- buttonNew+           containerAdd b l++           boxPackStart box b PackNatural 1++           on b buttonActivated $ do+             print ("SIGNAL: on focus", title)+             focusOnPage p+             return ()+        ) pages+  widgetShowAll box+  return ()
+ src/Utils.hs view
@@ -0,0 +1,85 @@+module Utils where++import Control.Concurrent.STM+import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk+import Data.Tree+import Data.Maybe+import Data.Tree.Zipper++import Datatypes++-- | wait until the TVar changes it's value from specified outer value+waitTVarChangeFrom :: (Eq a) => a -> (TVar a) -> IO a+waitTVarChangeFrom t tv = do+  tNew <- atomically $ do+                      t' <- readTVar tv+                      if (t' /= t) then return t' else retry+  return tNew++-- | wait until the TVar changes it's value from it's current value+waitTVarChange :: (Eq a) => (TVar a) -> IO a+waitTVarChange tv = readTVarIO tv >>= flip waitTVarChangeFrom tv++-- | block for two TVars to change their value from specified tuple value+waitTVarChangePairFrom :: (Eq a,Eq b) => (a,b) -> ((TVar a),(TVar b)) -> IO (a,b)+waitTVarChangePairFrom (ta,tb) (tva,tvb) = do+  tt <- atomically $ do+                      ta' <- readTVar tva+                      tb' <- readTVar tvb+                      let tt' = (ta',tb')+                      if tt' /= (ta,tb) then return tt' else retry+  return tt++-- | block for two TVars to change their value from their current values+waitTVarChangePair :: (Eq a,Eq b) => ((TVar a),(TVar b)) -> IO (a,b)+waitTVarChangePair tt@(tva,tvb) = do+  ta <- readTVarIO tva+  tb <- readTVarIO tvb+  waitTVarChangePairFrom (ta,tb) tt++++dontReenter :: TVar Bool -> IO a -> IO ()+dontReenter var act = do+  a' <- atomically $ do+          v <- readTVar var+          if v +           then return (return ()) +           else writeTVar var True >> return (act >> atomically (writeTVar var False))+  a'++callDepthCount :: TVar Int -> (Int -> IO a) -> IO ()+callDepthCount var act = do+  v <- atomically $ do+         v' <- readTVar var+         writeTVar var (v'+1)+         return v'+  act v+  atomically $ writeTVar var v++----------------+++isWidgetPage :: Widget -> Page -> IO Bool+isWidgetPage w p = do+  return (pgWidget p == w)++isSamePage :: Page -> Page -> Bool+isSamePage p1 p2 = pgWidget p1 == pgWidget p2++getPageTitle :: Page -> IO String+getPageTitle p = do+  mtit <- webViewGetTitle (pgWeb p)+  h <- readTVarIO (pgHistory p)+  case mtit of+    Nothing -> return (hiNow h)+    Just t -> return t++flattenToZipper :: Tree a -> [TreePos Full a]+flattenToZipper n@(Node _ sub) = fromTree n : concatMap flattenToZipper sub+++flattenToZipper' :: Tree a -> [TreePos Full a]+flattenToZipper' n = go (fromTree n) where+    go z = [z] ++ (fromMaybe [] (fmap go (firstChild z))) ++ (fromMaybe [] (fmap go (next z)))
+ src/VisualBrowseTree.hs view
@@ -0,0 +1,134 @@+module VisualBrowseTree where++++import Graphics.UI.Gtk.WebKit.WebFrame+import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.Download+import Graphics.UI.Gtk.WebKit.WebSettings+import Graphics.UI.Gtk.WebKit.NetworkRequest+import Graphics.UI.Gtk.WebKit.WebNavigationAction+-- import Graphics.UI.Gtk.WebKit.WebWindowFeatures++import System.IO.Unsafe+import System.Process+import System.Exit++import Graphics.UI.Gtk+import Text.Printf+import Control.Monad+import Control.Concurrent.STM+import Control.Concurrent++import qualified Data.Foldable as F+import qualified Data.Traversable as T+import Data.Tree.Zipper+import Data.Maybe+import qualified Data.List++import Utils+import NotebookSimple+import Datatypes++import Data.Tree as Tree+++browseTreeToSVG :: [Tree Page] -> IO String+browseTreeToSVG btree = do+  let ellipsis t n | length t < n = t+                   | otherwise = take n t ++ "..."++  nodeID <- newTVarIO (0::Int)+  btree' <- mapM (T.mapM (\p -> do+            i <- atomically $ do+                   iden <- readTVar nodeID+                   writeTVar nodeID (iden+1)+                   return iden+            t <- getPageTitle p+            return (i,t))) btree++  let prelude = unlines ["digraph \"Browse tree\" {",+                         "graph [",+                         "fontname = \"Helvetica-Oblique\",",+                         "page = 10",+                         "size = 30",+                         " ];"]+      -- labels = unlines [ printf "d%d [label=\"%s\"];" i t | (i,t) <- concatMap flatten btree' ]+      footer = "}"++      btreeZip = concatMap flattenToZipper' btree' -- ellipsis t 15+      labels = unlines [ printf "d%d [URL=\"http://google.com\", shape=polygon, fixedsize=true, fontsize=8, width=1.25, height=0.25, tooltip=\"%s\", label=\"%s\"];"+                                i t (ellipsis t 10) | (i,t) <- map label btreeZip ]+      edges = unlines [ printf "d%d -> d%d;" (fst . label . fromJust . parent $ z ) (fst . label $ z)+                            | z <- btreeZip,+                              parent z /= Nothing]++      edges2 =  [ ((fst . label . fromJust . parent $ z ),(fst . label $ z))+                      | z <- btreeZip,+                             parent z /= Nothing]+++      everything = prelude ++ edges ++ labels ++ footer++  print everything+  print edges2+  tot@(code,svg,dotErr) <- readProcessWithExitCode "dot" ["-Tsvg"] everything+ -- _ <- readProcessWithExitCode "dot" ["-Tsvg","-ograph.svg"] everything+ -- _ <- readProcessWithExitCode "dot" ["-ograph.dot"] everything+  print tot+  case code of+    ExitSuccess -> return svg+    ExitFailure c -> return $ printf "<text>Error running 'dot' command. Exit code: %s\n%s</text>" (show c) dotErr+++-- visualBrowseTreeWidget :: t -> IO Widget+visualBrowseTreeWidget :: TVar [Tree Page] -> IO Widget+visualBrowseTreeWidget btreeVar = do+  -- webkit widget+  web <- webViewNew+  webViewSetTransparent web True+  webViewSetFullContentZoom web True++  -- scrolled window to enclose the webkit+  scrollWeb <- scrolledWindowNew Nothing Nothing+  containerAdd scrollWeb web++  settings <- webViewGetWebSettings web+  set settings [webSettingsEnablePlugins := False]++  let refreshSVG = do+        svg <- browseTreeToSVG =<< readTVarIO btreeVar+        webViewLoadString web svg (Just "image/svg+xml") Nothing ""++  on web navigationPolicyDecisionRequested $ \ webframe networkReq webNavAct webPolDec -> do+    print "[navigationPolicyDecisionRequested]"+    muri <- networkRequestGetUri networkReq+    case muri of+      Nothing -> return ()+      Just uri -> print ("visualBrowseTreeWidget",uri)++    return True++  -- watch btreeVar for changes, update+  let watchdog page = do+          page' <- waitTVarChangeFrom page btreeVar+          postGUIAsync refreshSVG+          watchdog page'+  forkIO (watchdog =<< readTVarIO btreeVar)+  forkIO (forever $ do+            threadDelay (10^6)+            postGUIAsync refreshSVG)++  refreshSVG+  return (toWidget scrollWeb)++visualBrowseTreeWindow btreeVar = do+  window <- windowNew+  visualBT <- visualBrowseTreeWidget btreeVar+  set window [ containerBorderWidth := 10,+              windowTitle := "Spike browser - visual browse tree",+              containerChild := visualBT,+              windowAllowGrow := True ]+  widgetShowAll window++  return window
+ src/spike.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE PackageImports, FlexibleInstances, DoRec, ForeignFunctionInterface #-}+module Main where++import Graphics.UI.Gtk.WebKit.WebFrame+import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.Download+import Graphics.UI.Gtk.WebKit.WebSettings+import Graphics.UI.Gtk.WebKit.NetworkRequest+import Graphics.UI.Gtk.WebKit.WebNavigationAction++import System.IO.Unsafe+import System.Process+import System.Directory+import System.FilePath+import System.Exit++import Graphics.UI.Gtk+import Text.Printf+import Control.Monad+import Control.Concurrent.STM+import Control.Concurrent+import Control.Applicative+import Data.IORef++import qualified Data.Foldable as F+import qualified Data.Traversable as T+import Data.Tree.Zipper+import Data.Maybe+import qualified Data.List++import Utils+import NotebookSimple+import Datatypes+import VisualBrowseTree+import CFunctions++import Data.Tree as Tree++debugBTree :: [Tree Page] -> IO ()+debugBTree btree = do+  btree' <- mapM (T.mapM (\p -> fmap show $ getPageTitle p)) btree+  putStrLn (drawForest btree')+++-- operations on single page+-- | install listeners for various signals+hookupWebView :: WebViewClass object => object -> IO WebView -> IO ()+hookupWebView web createSubPage = do+  on web downloadRequested $ \ down -> do+         uri <- downloadGetUri down+         print ("Download uri",uri)+         return True++  let foo str webFr netReq webNavAct _webPolDec = do+                      t0 <- return str+                      t1 <- webFrameGetName webFr+                      t2 <- webFrameGetUri webFr+                      t3 <- networkRequestGetUri netReq+                      t4 <- webNavigationActionGetReason webNavAct+                      print (t0,t1,t2,t3,MyShow t4)+                      return False++  on web newWindowPolicyDecisionRequested $ foo "newWindowPolicyDecisionRequested"+-- on web navigationPolicyDecisionRequested ...++  on web createWebView $ \ frame -> do+    print "createWebView"+    newWebView <- createSubPage+    newUri <- webFrameGetUri frame+    case newUri of+      Just uri -> webViewLoadUri newWebView uri+      Nothing  -> return ()+    return newWebView++  -- on web downloadRequested $ \ _ -> print "downloadRequested" >> return False++ -- JavaScript stuff: TODO+ -- scriptAlert+ -- scriptConfirm+ -- scriptPrompt+ -- printRequested+ -- statusBarTextChanged+  on web consoleMessage $ \ s1 s2 i s3 -> print ("[JavaScript/Console message]: ",s1,s2,i,s3) >> return False+ -- closeWebView+ -- titleChanged++  hoveredLink <- newTVarIO Nothing++  on web hoveringOverLink $ \ title uri -> do+    -- print ("[hoveringOverLink]: ",title,uri)+    atomically $ writeTVar hoveredLink uri++  -- navigation+  on web navigationPolicyDecisionRequested $ \ webframe networkReq webNavAct webPolDec -> do+    print "[navigationPolicyDecisionRequested]"+    navReason <- webNavigationActionGetReason webNavAct+    case navReason of+      WebNavigationReasonLinkClicked -> do+        print (MyShow navReason)+        muri <- networkRequestGetUri networkReq+        kmod <- webNavigationActionGetModifierState webNavAct+        mbut <- webNavigationActionGetButton webNavAct+        print (muri,kmod,mbut)+        -- midle click and ctrl+click will spawn child+        -- shift+click spawn toplevel window+        case (mbut,kmod,muri) of+          -- middle click+          (2,_,Just uri) -> do+                     print ("loading uri in sub [1]",uri)+                     wv <- createSubPage+                     webViewLoadRequest wv networkReq+                     return True+          -- ctrl+click+          (_,4,Just uri) -> do+                     print ("loading uri in sub [2]",uri)+                     wv <- createSubPage+                     webViewLoadRequest wv networkReq+                     return True+          -- shift+click+          (_,1,Just uri) -> do+                     print ("loading uri in sub [3]",uri)+                     wv <- createSubPage+                     webViewLoadRequest wv networkReq+                     return True+          -- otherwise+          _ -> return False++--        print =<< webNavigationActionGetTargetFrame webNavAct+--        return False+      _ -> do+        print (MyShow navReason)+        return False++  -- new window via JavaScript+  on web newWindowPolicyDecisionRequested $ \ webframe networkReq webNavAct webPolDec -> do+    return False++--  on web Graphics.UI.Gtk.WebKit.WebView.populatePopup $ \ menu -> do+--    print ("[populate popup]")+--    hovered <- readTVarIO hoveredLink+--    case hovered of+--      Nothing -> return ()+--      Just uri -> do+--                   menuShellAppend menu =<< menuItemNewWithLabel ("1: " ++ uri)+--                   menuShellAppend menu =<< menuItemNewWithLabel ("2: " ++ uri)+--                   widgetShowAll menu++  -- statusBarTextChanged++  return ()++addressBarNew :: WebViewClass self => self -> IO Entry+addressBarNew web = do+  ec <- entryNew+  entrySetActivatesDefault ec True+  on ec entryActivate $ do+     text <- entryGetText ec+     webViewLoadUri web text+  on web loadCommitted $ \ frame -> do+     uri <- webFrameGetUri frame+     uri2 <- webViewGetUri web+     when (uri /= uri2) (print $ "INFO: addressBar: uri/uri2 mismatch: " ++ show (uri,uri2))+     case catMaybes [uri,uri2] of+       (x:_) -> entrySetText ec x+       _ -> print ("INFO: addressBar: no text to set")+     return ()+  return ec++newWeb :: BrowseTreeState -> IO () -> String -> IO (Widget, WebView)+newWeb btreeSt refreshLayout url = do+  -- webkit widget+  web <- webViewNew+  webViewSetTransparent web False+  let loadHome = webViewLoadUri web url+  loadHome+  -- webViewSetMaintainsBackForwardList web False -- TODO: or maybe True?+  on web titleChanged $ \ _ _ -> refreshLayout++  -- plugins are causing trouble. disable them.+  settings <- webViewGetWebSettings web+  set settings [webSettingsEnablePlugins := False]++  -- scrolled window to enclose the webkit+  scrollWeb <- scrolledWindowNew Nothing Nothing+  containerAdd scrollWeb web++  -- menu+  addressBar <- addressBarNew web+  menu <- hBoxNew False 1+  quit <- buttonNewWithLabel "Quit"+  reload <- buttonNewWithLabel "Reload"+  on reload buttonActivated $ webViewReload web+  goHome <- buttonNewWithLabel "Home"+  on goHome buttonActivated $ loadHome+  boxPackEnd menu quit PackNatural 1+  boxPackStart menu reload PackNatural 1+  boxPackStart menu goHome PackNatural 1+  boxPackStart menu addressBar PackGrow 1++  -- fill the page+  page <- vPanedNew+  containerAdd page menu+  containerAdd page scrollWeb++  widgetShowAll page++  let widget = toWidget page+      ww = (widget,web)+      newChildPage = do+        print "[newChildPage called]"+        btree <- readTVarIO btreeSt+        debugBTree btree+        case findPageWidget btree widget of+          Just p -> do+            ww' <- newWeb btreeSt refreshLayout "about:blank"+            p' <- newPage ww' "about:blank" -- TODO: win the battle over the power to navigate the web view.+            let btree' = addChild btree p p'+            atomically $ writeTVar btreeSt btree'+            refreshLayout+            return (pgWeb p')+          Nothing -> do+            error "findPageWidget returned Nothing, can't provide a new window"++  hookupWebView web newChildPage++  return ww++-- move to new page, discard any hiNext out there+navigateToPage :: Page -> String -> IO ()+navigateToPage page url = do+  atomically $ do+    hist <- readTVar (pgHistory page)+    let h' = Hist url (hiNow hist : hiPrev hist) []+    writeTVar (pgHistory page) h'++  webViewLoadUri (pgWeb page) url++-- operations on tree+newTopPage :: BrowseTreeState -> IO () -> String -> IO Page+newTopPage btvar refreshLayout url = do+  ww <- newWeb btvar refreshLayout url+  tp <- newLeafURL ww url+  atomically $ do+    bt <- readTVar btvar+    writeTVar btvar (bt ++ [tp])+  return (rootLabel tp)++newLeafURL :: (Widget, WebView) -> String -> IO (Tree Page)+newLeafURL ww url = do+  page <- (newPage ww url)+  return (newLeaf page)++newPage :: (Widget, WebView) -> String -> IO Page+newPage (widget,webv) url = do+  hist <- newTVarIO (Hist url [] [])+  return (Page { pgWidget=widget, pgWeb=webv, pgHistory=hist})++newLeaf :: Page -> Tree Page+newLeaf page = Node page []++addChild :: BrowseTree -> Page -> Page -> BrowseTree+addChild btree parent child = let+    aux (Node page sub) | isSamePage page parent = Node page (sub ++ [newLeaf child])+                        | otherwise              = Node page (map aux sub)+    in map aux btree++-- query functions++findPageWidget :: BrowseTree -> Widget -> Maybe Page+findPageWidget btree w = let fun p = pgWidget p == w+                             flat = concatMap flatten btree+                             filt = filter fun flat+                         in+                           case filt of+                             [] -> Nothing+                             (x:_) -> Just x++getPageSurrounds :: Eq a => [Tree a] -> a -> ([a], [a], [a])+getPageSurrounds btree p | not (any (F.elem p) btree) = ([],[p],[])+                         | otherwise =+                             let parent = getPageParent btree p+                                 parents = case parent of+                                             Nothing -> []+                                             Just x -> map rootLabel (getPageSiblings btree (rootLabel x))+                                 siblings = map rootLabel (getPageSiblings btree p)+                                 children = map rootLabel (getPageChildren btree p)+                             in (parents,siblings,children)++-- returns node's siblings+getPageSiblings :: Eq b => [Tree b] -> b -> [Tree b]+getPageSiblings btree p = case getPageParent btree p of+                            Nothing -> btree+                            Just x -> subForest x++getPageChildren :: Eq b => [Tree b] -> b -> Forest b+getPageChildren btree p = case filter ((==p) . rootLabel) (concatMap subtrees btree) of+                            [] -> error "Element (page) not found in Forest"+                            (Node _ sub:_) -> sub++getPageParent :: Eq b => [Tree b] -> b -> Maybe (Tree b)+getPageParent btree p = case (filter (any ((==p) . rootLabel) . subForest) (subtrees' btree)) of+                            [] -> Nothing+                            (x:_xs) -> Just x++subtrees :: Tree t -> [Tree t]+subtrees t@(Node _ sub) = t : subtrees' sub++subtrees' :: [Tree t] -> [Tree t]+subtrees' = concatMap subtrees++-- notebook synchronization++viewPagesSimpleNotebook :: [Page] -> NotebookSimple -> IO ()+viewPagesSimpleNotebook pages nb = do+  atomically $ writeTVar (ns_pages nb) pages+  ns_refresh nb++noEntriesInBox :: ContainerClass self => self -> IO ()+noEntriesInBox box = do+  containerForeach box (containerRemove box)+  label <- labelNew Nothing+  labelSetMarkup label "<span color=\"#909090\">(no elements here)</span>"+  containerAdd box label+  widgetShowAll box++--------------++setupGlobals = do+  appDir <- getAppUserDataDirectory "Spike"+  createDirectoryIfMissing False appDir++  spikeSetupWebkitGlobals (appDir </> "spike.webkit.db") (appDir </> "spike.webkit.cookie.db")++main :: IO ()+main = do+ initGUI++ setupGlobals+ + -- glue together gui. yuck.+ parentsBox <- hBoxNew False 1   :: IO HBox++ viewPageRef <- newIORef undefined+ siblingsNotebookSimple <- notebookSimpleNew (\p -> do { fun <- readIORef viewPageRef; fun p}) :: IO NotebookSimple+ childrenBox <- hBoxNew False 1  :: IO HBox++ widgetSetSizeRequest parentsBox (-1) 40+ widgetSetSizeRequest childrenBox (-1) 40++ inside <- vBoxNew False 1+ (\sw -> boxPackStart inside sw PackNatural 1) =<< newScrolledWindowWithViewPort parentsBox+ boxPackStart inside (ns_widget siblingsNotebookSimple) PackGrow 1+ (\sw -> boxPackStart inside sw PackNatural 1) =<< newScrolledWindowWithViewPort childrenBox+++ -- global state++ currentPage <- newTVarIO (error "current page is undefined for now...")+ btreeVar <- newTVarIO []++ -- define refresh layout and others++ let viewPage :: Page -> IO ()+     viewPage page = do+       print "CALL: viewPage"+       atomically $ writeTVar currentPage page+       refreshLayout+   +     refreshLayout = do+       print "CALL: refreshLayout"++       btree <- readTVarIO btreeVar+       page <- readTVarIO currentPage+       let (parents,siblings,children) = getPageSurrounds btree page++       viewPagesSimpleNotebook siblings siblingsNotebookSimple+       notebookSimpleSelectPage siblingsNotebookSimple page++       case parents of+         [] -> noEntriesInBox parentsBox+         parents' -> listPagesBox viewPage parents' parentsBox    -- update parents+       case children of+         [] -> noEntriesInBox childrenBox+         children' -> listPagesBox viewPage children' childrenBox  -- update children+++     spawnHomepage = do+         let homepage = "https://google.com"+         page <- newTopPage btreeVar refreshLayout homepage+         atomically $ writeTVar currentPage page+         notebookSimpleSelectPage siblingsNotebookSimple page+         viewPage page+         return ()++ writeIORef viewPageRef viewPage++ -- create root page++ spawnHomepage+ newTopPage btreeVar refreshLayout "http://news.google.com"++ -- show main window+ window <- windowNew+ onDestroy window mainQuit+ set window [ containerBorderWidth := 10,+              windowTitle := "Spike browser",+              containerChild := inside,+              windowAllowGrow := True ]+ widgetShowAll window++ -- tree view window+ visualBrowseTreeWindow btreeVar++ -- refresh layout once and run GTK loop+ refreshLayout+ mainGUI++ return ()