spike 0.1 → 0.2
raw patch · 9 files changed
+553/−354 lines, 9 filesdep +glibdep +global-variablesdep +random
Dependencies added: glib, global-variables, random
Files
- spike.cabal +7/−3
- src/BrowseTreeOperations.hs +322/−0
- src/Commands.hs +83/−0
- src/Datatypes.hs +27/−16
- src/GlobalVariables.hs +20/−0
- src/NotebookSimple.hs +5/−0
- src/Utils.hs +10/−5
- src/VisualBrowseTree.hs +37/−27
- src/spike.hs +42/−303
spike.cabal view
@@ -1,5 +1,5 @@ Name: spike-Version: 0.1+Version: 0.2 Synopsis: Experimental web browser Description: Experimental web browser based on WebKit-Gtk+ License: BSD3@@ -18,9 +18,13 @@ Executable spike Main-is: spike.hs- Other-modules: Utils, VisualBrowseTree, Datatypes, Graphs, CFunctions, NotebookSimple+ Other-modules: Utils, VisualBrowseTree, Datatypes, Graphs, + CFunctions, NotebookSimple, GlobalVariables, + Commands, BrowseTreeOperations Hs-source-dirs: src- Build-depends: webkit == 0.12.*, containers, gtk, base == 4.*, stm, mtl > 2, rosezipper, process, directory, filepath+ Build-depends: webkit == 0.12.*, containers, gtk, base == 4.*, + stm, mtl > 2, rosezipper, process, directory, + filepath, glib, random, global-variables Ghc-options: -rtsopts C-sources: cbits/cbits.c pkgconfig-depends: libsoup-gnome-2.4
+ src/BrowseTreeOperations.hs view
@@ -0,0 +1,322 @@+module BrowseTreeOperations where++import Graphics.UI.Gtk++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 Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad++import Data.IORef+import Data.Maybe+import Data.Tree as Tree+import Data.Tree.Zipper++-- import System.Directory+-- import System.Exit+-- import System.FilePath+-- import System.IO.Unsafe+-- import System.Process+-- import System.Random++import Text.Printf++import qualified Data.Foldable as F+import qualified Data.List+import qualified Data.Traversable as T++import CFunctions+import Commands+import Datatypes+import GlobalVariables+import NotebookSimple+import Utils+import VisualBrowseTree++--------------------- web view stuff++-- 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 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++ 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++ _ -> do+ print (MyShow navReason)+ return False++ -- new window via JavaScript+ on web newWindowPolicyDecisionRequested $ \ webframe networkReq webNavAct webPolDec -> do+ return False++ -- 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+ page <- vPanedNew+ let thisWidget = toWidget page++ -- 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"+ on quit buttonActivated $ do+ p <- findPageByView pgWidget thisWidget+ case p of+ Nothing -> return ()+ Just pg -> sendCommand (ClosePageCommand (pgIdent pg))++ 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+ containerAdd page menu+ containerAdd page scrollWeb++ widgetShowAll page++ let ww = (thisWidget,web)+ newChildPage = do+ print "[newChildPage called]"+ btree <- readTVarIO btreeSt+ debugBTree btree+ case findPageWidget btree thisWidget 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++----------------------++debugBTree :: [Tree Page] -> IO ()+debugBTree btree = do+ btree' <- mapM (T.mapM (\p -> fmap show $ getPageTitle p)) btree+ putStrLn (drawForest btree')++-- 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+ ident <- atomically $ do+ i <- readTVar pageIdentVar+ writeTVar pageIdentVar $! (i+1)+ return i++ return (Page { pgWidget = widget+ , pgWeb = webv+ , pgIdent = ident+ , pgStartURI = url+ })++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++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+++findPageByView :: (Eq a) => (Page -> a) -> a -> IO (Maybe Page)+findPageByView view el = do+ pages <- readTVarIO browseTreeVar+ return (listToMaybe $ catMaybes (map (F.find (\p -> view p == el)) pages))++findPageByID :: PageID -> IO (Maybe Page)+findPageByID = findPageByView pgIdent++--findPageByID pid = do+-- pages <- readTVarIO browseTreeVar+-- return (listToMaybe $ catMaybes (map (F.find (\p -> pgIdent p == pid)) pages))++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
+ src/Commands.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification #-}++module Commands where++import Datatypes++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Data.Global+import Data.IORef+import Data.Typeable++-- | commands channel. base implementations only do some logging, they need to be replaced with proper implementations when appropriate.+commandChannelVar :: IORef CommandControl+commandChannelVar = declareIORef "spike::global::commandChannel" emptyCommandControl++data CommandControl = CommandControl { sendCommand_ :: SomeCommand -> IO ()+ , registerListener_ :: (SomeCommand -> IO ()) -> IO () + } deriving Typeable++data SomeCommand = forall e . Command e => SomeCommand e deriving Typeable++instance Show SomeCommand where+ showsPrec p (SomeCommand e) = showsPrec p e++-- | Command class. Design copied after System.Exception.Exception class+class (Typeable c, Show c) => Command c where+ toCommand :: c -> SomeCommand+ fromCommand :: SomeCommand -> Maybe c++ toCommand = SomeCommand+ fromCommand (SomeCommand c) = Data.Typeable.cast c++sendCommand :: Command c => c -> IO ()+sendCommand c = do+ cc <- readIORef commandChannelVar+ sendCommand_ cc (toCommand c)++registerListener :: (Command c) => (c -> IO ()) -> IO ()+registerListener l = do+ cc <- readIORef commandChannelVar+ registerListener_ cc (\ c -> case fromCommand c of+ Nothing -> return ()+ Just x -> l x)++emptyCommandControl = CommandControl+ (\ _ -> print "(default) sendCommand: command ignored")+ (\ _ -> print "(default) registerListener: listener ignored")++setupCommandControl :: IO ()+setupCommandControl = do+ commandChan <- newChan+ listeners <- newTVarIO []++ let send c = writeChan commandChan c + register l = atomically $ do+ ls <- readTVar listeners+ writeTVar listeners (l:ls)++ handleCommand c = do+ ls <- readTVarIO listeners+ let logException c e = putStrLn $ "Exception while handling command: " ++ show c ++ " " ++ show (e :: SomeException)+ mapM_ (\ handler -> forkIO (Control.Exception.catch (handler c) (logException c))) ls++ forkIO $ do+ commands <- getChanContents commandChan+ mapM_ handleCommand commands++ let cc = CommandControl send register+ writeIORef commandChannelVar cc+ return ()++-- commands+data ViewPageCommand = ViewPageCommand PageID deriving (Typeable, Show) -- which page+data NewTopLevelPageCommand = NewTopLevelPageCommand URL deriving (Typeable, Show) -- url+data NewChildPageCommand = NewChildPageCommand PageID URL deriving (Typeable, Show) -- parent, url+data ClosePageCommand = ClosePageCommand PageID deriving (Typeable, Show) -- which page++instance Command ViewPageCommand where+instance Command NewChildPageCommand where+instance Command NewTopLevelPageCommand where+instance Command ClosePageCommand where
src/Datatypes.hs view
@@ -1,19 +1,25 @@-{-# LANGUAGE PackageImports, FlexibleInstances, DoRec, ForeignFunctionInterface #-}+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable #-}+ 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+import Data.Typeable+import Graphics.UI.Gtk+import Graphics.UI.Gtk.WebKit.WebNavigationAction+import Graphics.UI.Gtk.WebKit.WebView -data History = Hist { hiNow :: String, hiPrev :: [String], hiNext :: [String] } deriving Show+data Page = Page { pgWeb :: WebView+ , pgWidget :: Widget+ , pgIdent :: Int+ , pgStartURI :: String }+ deriving Typeable+ -data Page = Page { pgWeb :: WebView, pgWidget :: Widget, pgHistory :: TVar History }+type PageID = Int+type PageLink = String -instance Show Page where- show pg = "Page { pgWeb=?, pgWidget=?, pgHistory=" ++ show (unsafeDupablePerformIO (readTVarIO (pgHistory pg))) ++ "}"+type URL = String instance Eq Page where p1 == p2 = pgWidget p1 == pgWidget p2@@ -21,12 +27,17 @@ type BrowseTree = Forest Page type BrowseTreeState = TVar BrowseTree --- wrapper newtype to avoid orphan instances+-- | 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"+ show (MyShow WebNavigationReasonLinkClicked ) = "WebNavigationReasonLinkClicked"+ show (MyShow WebNavigationReasonFormSubmitted ) = "WebNavigationReasonFormSubmitted"+ show (MyShow WebNavigationReasonBackForward ) = "WebNavigationReasonBackForward"+ show (MyShow WebNavigationReasonReload ) = "WebNavigationReasonReload"+ show (MyShow WebNavigationReasonFormResubmitted) = "WebNavigationReasonFormResubmitted"+ show (MyShow WebNavigationReasonOther ) = "WebNavigationReasonOther"++-- | wrapper type for things that doesn't really have Show instance defined, like functions+data DontShow a = DontShow { fromDontShow :: a } deriving Typeable+instance Show (DontShow a) where+ showsPrec p _ = showsPrec p "DontShow {contents are hidden}"
+ src/GlobalVariables.hs view
@@ -0,0 +1,20 @@+module GlobalVariables where++import Data.Global+import Datatypes++import Data.IORef+import Control.Concurrent.STM+import Control.Concurrent++-- | stores the whole browse tree state+browseTreeVar :: BrowseTreeState+browseTreeVar = declareTVar "spike::global::browseTree" []++-- | current page+currentPageVar :: TVar Page+currentPageVar = declareTVar "spike::global::currentPage" (error "current page not yet set")++-- | page counter -- for pgIdent+pageIdentVar :: TVar Int+pageIdentVar = declareTVar "spike::global::pageIdentCounter" 0
src/NotebookSimple.hs view
@@ -20,6 +20,11 @@ , ns_refresh :: IO () } +viewPagesSimpleNotebook :: [Page] -> NotebookSimple -> IO ()+viewPagesSimpleNotebook pages nb = do+ atomically $ writeTVar (ns_pages nb) pages+ ns_refresh nb+ newScrolledWindowWithViewPort :: WidgetClass child => child -> IO ScrolledWindow newScrolledWindowWithViewPort child = do sw <- scrolledWindowNew Nothing Nothing
src/Utils.hs view
@@ -2,6 +2,8 @@ import Control.Concurrent.STM import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.WebHistoryItem+import Graphics.UI.Gtk.WebKit.WebBackForwardList import Graphics.UI.Gtk import Data.Tree import Data.Maybe@@ -70,11 +72,14 @@ 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+ let web = pgWeb p+ mtit <- webViewGetTitle web+ muri <- webViewGetUri web+ bflst <- webViewGetBackForwardList web++ let titles = catMaybes [mtit, muri] ++ [pgStartURI p]++ return $ head titles flattenToZipper :: Tree a -> [TreePos Full a] flattenToZipper n@(Node _ sub) = fromTree n : concatMap flattenToZipper sub
src/VisualBrowseTree.hs view
@@ -1,36 +1,32 @@ module VisualBrowseTree where +import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad +import Data.Maybe+import Data.Tree+import Data.Tree.Zipper+import qualified Data.Foldable as Foldable+import qualified Data.Traversable as T -import Graphics.UI.Gtk.WebKit.WebFrame-import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk import Graphics.UI.Gtk.WebKit.Download-import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.WebKit.NetworkRequest+import Graphics.UI.Gtk.WebKit.WebFrame import Graphics.UI.Gtk.WebKit.WebNavigationAction--- import Graphics.UI.Gtk.WebKit.WebWindowFeatures+import Graphics.UI.Gtk.WebKit.WebSettings+import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.WebWindowFeatures -import System.IO.Unsafe-import System.Process import System.Exit--import Graphics.UI.Gtk+import System.Process 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+import Commands browseTreeToSVG :: [Tree Page] -> IO String@@ -45,7 +41,7 @@ writeTVar nodeID (iden+1) return iden t <- getPageTitle p- return (i,t))) btree+ return (i,(t,mkStablePageLink p)))) btree let prelude = unlines ["digraph \"Browse tree\" {", "graph [",@@ -57,8 +53,8 @@ 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 ]+ labels = unlines [ printf "d%d [URL=\"%s\", shape=polygon, fixedsize=true, fontsize=8, width=1.25, height=0.25, tooltip=\"%s\", label=\"%s\"];"+ i link t (ellipsis t 10) | (i,(t,link)) <- map label btreeZip ] edges = unlines [ printf "d%d -> d%d;" (fst . label . fromJust . parent $ z ) (fst . label $ z) | z <- btreeZip, parent z /= Nothing]@@ -80,10 +76,18 @@ ExitSuccess -> return svg ExitFailure c -> return $ printf "<text>Error running 'dot' command. Exit code: %s\n%s</text>" (show c) dotErr +-- mkStablePageLink page = let (GObject foreignPtr) = toGObject (pgWidget page) in PageLink foreignPtr +lookupStablePageLink :: [Tree Page] -> PageLink -> Maybe Page+lookupStablePageLink pages link = listToMaybe $ catMaybes (map (Foldable.find (\p -> mkStablePageLink p == link)) pages)+mkStablePageLink page = "page://" ++ (show $ pgIdent page)++mkLinks :: [Page] -> [PageLink]+mkLinks = map mkStablePageLink+ -- visualBrowseTreeWidget :: t -> IO Widget-visualBrowseTreeWidget :: TVar [Tree Page] -> IO Widget-visualBrowseTreeWidget btreeVar = do+visualBrowseTreeWidget :: (Page -> IO ()) -> TVar [Tree Page] -> IO Widget+visualBrowseTreeWidget viewPage btreeVar = do -- webkit widget web <- webViewNew webViewSetTransparent web True@@ -105,7 +109,13 @@ muri <- networkRequestGetUri networkReq case muri of Nothing -> return ()- Just uri -> print ("visualBrowseTreeWidget",uri)+ Just uri -> do+ print ("visualBrowseTreeWidget",uri)+ t <- readTVarIO btreeVar+ case lookupStablePageLink t uri of+ Nothing -> print ("Page no longer exist: " ++ show uri)+-- Just p -> viewPage p+ Just p -> sendCommand (ViewPageCommand (pgIdent p)) -- viewPage p return True @@ -122,9 +132,9 @@ refreshSVG return (toWidget scrollWeb) -visualBrowseTreeWindow btreeVar = do+visualBrowseTreeWindow viewPage btreeVar = do window <- windowNew- visualBT <- visualBrowseTreeWidget btreeVar+ visualBT <- visualBrowseTreeWidget viewPage btreeVar set window [ containerBorderWidth := 10, windowTitle := "Spike browser - visual browse tree", containerChild := visualBT,
src/spike.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE PackageImports, FlexibleInstances, DoRec, ForeignFunctionInterface #-} module Main where +import Graphics.UI.Gtk+ import Graphics.UI.Gtk.WebKit.WebFrame import Graphics.UI.Gtk.WebKit.WebView import Graphics.UI.Gtk.WebKit.Download@@ -8,313 +10,39 @@ import Graphics.UI.Gtk.WebKit.NetworkRequest import Graphics.UI.Gtk.WebKit.WebNavigationAction -import System.IO.Unsafe-import System.Process+import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad++import Data.IORef+import Data.Maybe+import Data.Tree as Tree+import Data.Tree.Zipper+ import System.Directory-import System.FilePath import System.Exit+import System.FilePath+import System.IO.Unsafe+import System.Process+import System.Random -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 qualified Data.Traversable as T -import Utils-import NotebookSimple+import CFunctions+import Commands import Datatypes+import GlobalVariables+import NotebookSimple+import Utils 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+import BrowseTreeOperations -- 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)@@ -324,7 +52,6 @@ widgetShowAll box --------------- setupGlobals = do appDir <- getAppUserDataDirectory "Spike" createDirectoryIfMissing False appDir@@ -333,8 +60,11 @@ main :: IO () main = do- initGUI+ -- experimental+ setupCommandControl + -- init gui & webkit+ initGUI setupGlobals -- glue together gui. yuck.@@ -352,11 +82,11 @@ 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 []+ -- currentPage <- newTVarIO (error "current page is undefined for now...")+ -- btreeVar <- newTVarIO []+ let currentPage = GlobalVariables.currentPageVar+ btreeVar = GlobalVariables.browseTreeVar -- define refresh layout and others @@ -392,10 +122,19 @@ viewPage page return () + -- experimental: command listeners+ registerListener (\ (ViewPageCommand pid) -> + do+ p <- findPageByID pid+ case p of+ Nothing -> return ()+ Just pg -> viewPage pg)++ registerListener (\ (NewTopLevelPageCommand url) -> newTopPage btreeVar refreshLayout url >> return ())+ writeIORef viewPageRef viewPage -- create root page- spawnHomepage newTopPage btreeVar refreshLayout "http://news.google.com" @@ -409,7 +148,7 @@ widgetShowAll window -- tree view window- visualBrowseTreeWindow btreeVar+ visualBrowseTreeWindow viewPage btreeVar -- refresh layout once and run GTK loop refreshLayout