hbro 0.6.8 → 0.6.8.1
raw patch · 9 files changed
+192/−56 lines, 9 files
Files
- Hbro/Config.hs +0/−36
- Hbro/Core.hs +54/−6
- Hbro/Extra/Misc.hs +101/−1
- Hbro/Extra/StatusBar.hs +16/−2
- Hbro/Gui.hs +3/−3
- Hbro/Main.hs +1/−1
- examples/hbro.hs +4/−2
- examples/ui.xml +9/−0
- hbro.cabal +4/−5
− Hbro/Config.hs
@@ -1,36 +0,0 @@-module Hbro.Config where---- {{{ Imports-import Hbro.Core-import Hbro.Types--import qualified Config.Dyre as Dyre--import Graphics.UI.Gtk.WebKit.WebSettings--- }}}---showError :: Configuration -> String -> Configuration-showError configuration message = configuration { mError = Just message }--hbro :: Configuration -> IO ()-hbro = Dyre.wrapMain Dyre.defaultParams {- Dyre.projectName = "hbro",- Dyre.showError = showError,- Dyre.realMain = realMain,- Dyre.ghcOpts = ["-threaded"]-}---- | Default configuration.--- Does quite nothing.-defaultConfiguration :: Configuration-defaultConfiguration = Configuration {- mHomePage = "https://www.google.com",- mSocketDir = "/tmp/",- mUIFile = "~/.config/hbro/ui.xml",- mKeys = [],- mWebSettings = webSettingsNew,- mSetup = \_ -> return () :: IO (),- mCommands = [],- mError = Nothing-}
Hbro/Core.hs view
@@ -7,6 +7,9 @@ import Hbro.Types import Hbro.Util +import qualified Config.Dyre as D+import Config.Dyre.Paths+ import Control.Concurrent import Control.Monad.Trans(liftIO) @@ -21,21 +24,23 @@ import Graphics.UI.Gtk.Scrolling.ScrolledWindow import Graphics.UI.Gtk.WebKit.WebDataSource import Graphics.UI.Gtk.WebKit.WebFrame+import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.WebKit.WebView import Network.URL import System.Console.CmdArgs import System.Glib.Signals+import System.IO import System.Process import System.Posix.Process import qualified System.ZMQ as ZMQ -- }}} - -- {{{ Commandline options+-- | Available commandline options cliOptions :: CliOptions-cliOptions = CliOptions{+cliOptions = CliOptions { mURI = def &= help "URI to open at start-up" &= explicit &= name "u" &= name "uri" &= typ "URI" } @@ -48,8 +53,40 @@ &= program "hbro" -- }}} +-- {{{ Configuration+dyreParameters :: D.Params Configuration+dyreParameters = D.defaultParams {+ D.projectName = "hbro",+ D.showError = showError,+ D.realMain = realMain,+ D.ghcOpts = ["-threaded"],+ D.statusOut = hPutStrLn stderr+} +showError :: Configuration -> String -> Configuration+showError configuration message = configuration { mError = Just message }++-- | Default configuration.+-- Does quite nothing.+defaultConfiguration :: Configuration+defaultConfiguration = Configuration {+ mHomePage = "https://www.google.com",+ mSocketDir = "/tmp/",+ mUIFile = "~/.config/hbro/ui.xml",+ mKeys = [],+ mWebSettings = webSettingsNew,+ mSetup = \_ -> return () :: IO (),+ mCommands = [],+ mError = Nothing+}+-- }}}+ -- {{{ Entry point+-- | Browser's main function.+-- To be called in function "main" with a proper configuration.+hbro :: Configuration -> IO ()+hbro = D.wrapMain dyreParameters+ -- | Entry point for the application. -- Parse commandline arguments, print configuration error if any, -- create browser and load homepage.@@ -58,12 +95,22 @@ -- Parse commandline arguments options <- getOptions +-- Print in-use paths+ (a, b, c, d, e) <- getPaths dyreParameters+ whenLoud $ do+ putStrLn ("Current binary: " ++ a)+ putStrLn ("Custom binary: " ++ b)+ putStrLn ("Config file: " ++ c)+ putStrLn ("Cache directory: " ++ d)+ putStrLn ("Lib directory: " ++ e)+ putStrLn ""+ -- Print configuration error, if any- maybe (return ()) putStrLn (mError config)+ maybe (return ()) putStrLn $ mError config -- Initialize GUI _ <- initGUI- gui <- loadGUI (mUIFile config)+ gui <- loadGUI $ mUIFile config let browser = Browser options config gui let webView = mWebView gui let window = mWindow gui@@ -139,7 +186,6 @@ whenNormal $ putStrLn "Exiting..." -- }}} - -- {{{ Browsing functions -- | Load homepage (set from configuration file). goHome :: Browser -> IO ()@@ -245,7 +291,9 @@ -- | Spawn a new instance of the browser. newInstance :: IO ()-newInstance = spawn (proc "hbro" [])+newInstance = do + (binary, _, _, _, _) <- getPaths dyreParameters + spawn $ proc binary [] -- | Execute a javascript file on current webpage. executeJSFile :: String -> Browser -> IO ()
Hbro/Extra/Misc.hs view
@@ -1,13 +1,113 @@ module Hbro.Extra.Misc where -- {{{ Imports-import Hbro.Core+import Hbro.Core hiding(goBack, goForward) import Hbro.Types+import Hbro.Util +import Data.Maybe++import Graphics.UI.Gtk.Builder+import Graphics.UI.Gtk.Display.Label+import Graphics.UI.Gtk.WebKit.WebBackForwardList+import Graphics.UI.Gtk.WebKit.WebHistoryItem import Graphics.UI.Gtk.WebKit.WebView++import System.IO+import System.Process -- }}} +-- | Same as goBack function from Hbro.Core,+-- but with feedback in case of failure.+goForward :: Browser -> IO ()+goForward browser = do+ result <- webViewCanGoForward webView+ feedbackLabel <- builderGetObject builder castToLabel "feedback"++ case result of+ True -> webViewGoForward webView+ _ -> labelSetMarkupTemporary feedbackLabel "<span foreground=\"red\">Unable to go forward !</span>" 5000 >> return ()++ where+ webView = mWebView $ mGUI browser+ builder = mBuilder $ mGUI browser++-- | Same as goBack function from Hbro.Core,+-- but with feedback in case of failure.+goBack :: Browser -> IO ()+goBack browser = do+ result <- webViewCanGoBack webView+ feedbackLabel <- builderGetObject builder castToLabel "feedback"++ case result of+ True -> webViewGoBack webView+ _ -> labelSetMarkupTemporary feedbackLabel "<span foreground=\"red\">Unable to go back !</span>" 5000 >> return ()++ where+ webView = mWebView $ mGUI browser+ builder = mBuilder $ mGUI browser+++-- | List preceding URIs in dmenu and let the user select which one to load.+goBackList :: Browser -> IO ()+goBackList browser = do+ list <- webViewGetBackForwardList webView+ n <- webBackForwardListGetBackLength list+ backList <- webBackForwardListGetBackListWithLimit list n+ dmenuList <- mapM itemToEntry backList++ (Just input, Just output, _, _) <- createProcess (proc "dmenu" ["-l", "10"]) {+ std_in = CreatePipe,+ std_out = CreatePipe }++ _ <- hPutStr input $ unlines (catMaybes dmenuList)+ entry <- catch (hGetLine output) (\_error -> return "ERROR" )++ case words entry of+ ["ERROR"] -> return ()+ uri:_ -> loadURI uri browser+ _ -> return ()+ return ()+ where+ webView = mWebView $ mGUI browser+ ++-- | List succeeding URIs in dmenu and let the user select which one to load.+goForwardList :: Browser -> IO ()+goForwardList browser = do+ list <- webViewGetBackForwardList webView+ n <- webBackForwardListGetForwardLength list+ forwardList <- webBackForwardListGetForwardListWithLimit list n+ dmenuList <- mapM itemToEntry forwardList++ (Just input, Just output, _, _) <- createProcess (proc "dmenu" ["-l", "10"]) {+ std_in = CreatePipe,+ std_out = CreatePipe }++ _ <- hPutStr input $ unlines (catMaybes dmenuList)+ entry <- catch (hGetLine output) (\_error -> return "ERROR" )++ case words entry of+ ["ERROR"] -> return ()+ uri:_ -> loadURI uri browser+ _ -> return ()+ return ()+ where+ webView = mWebView $ mGUI browser+++itemToEntry :: WebHistoryItem -> IO (Maybe String)+itemToEntry item = do+ title <- webHistoryItemGetTitle item+ uri <- webHistoryItemGetUri item+ case uri of+ Just u -> return $ Just (u ++ " | " ++ (maybe "Untitled" id title))+ _ -> return Nothing+++-- | Toggle source display.+-- Current implementation forces a refresh of current web page, which may be undesired. toggleSourceMode :: Browser -> IO () toggleSourceMode browser = do currentMode <- webViewGetViewSourceMode (mWebView $ mGUI browser)
Hbro/Extra/StatusBar.hs view
@@ -44,8 +44,22 @@ scrollWindow = mScrollWindow (mGUI browser) +-- | Display current zoom level in status bar.+-- Needs a Label entitled "zoom" from the builder.+statusBarZoomLevel :: Browser -> IO ()+statusBarZoomLevel browser = do+ zoomLevel <- webViewGetZoomLevel webView+ zoomLabel <- builderGetObject builder castToLabel "zoom"+ + labelSetMarkup zoomLabel $ "<span foreground=\"white\">x" ++ escapeMarkup (show zoomLevel) ++ "</span>"+ where+ builder = mBuilder (mGUI browser)+ webView = mWebView (mGUI browser)+++ -- | Display pressed keys in status bar.--- Needs a Label intitled "keys" from the builder.+-- Needs a Label entitled "keys" from the builder. statusBarPressedKeys :: Browser -> IO () statusBarPressedKeys browser = let@@ -69,7 +83,7 @@ -- | Display load progress in status bar.--- Needs a Label intitled "progress" from the builder.+-- Needs a Label entitled "progress" from the builder. statusBarLoadProgress :: Browser -> IO () statusBarLoadProgress browser = let
Hbro/Gui.hs view
@@ -29,9 +29,9 @@ -- | Load GUI from XML file loadGUI :: String -> IO GUI loadGUI xmlPath = do- whenNormal $ putStrLn ("Loading GUI from " ++ xmlPath ++ "...")+ whenNormal $ putStr ("Loading GUI from " ++ xmlPath ++ "... ") --- +-- Load XML builder <- builderNew builderAddFromFile builder xmlPath @@ -60,7 +60,7 @@ inspector <- webViewGetInspector webView inspectorWindow <- initWebInspector inspector - whenLoud $ putStrLn "Done."+ whenNormal $ putStrLn "Done." return $ GUI window inspectorWindow scrollWindow webView promptLabel promptEntry statusBox builder
Hbro/Main.hs view
@@ -1,7 +1,7 @@ module Main where -- {{{ Imports-import Hbro.Config+import Hbro.Core import Hbro.Types import Paths_hbro
examples/hbro.hs view
@@ -1,8 +1,7 @@ module Main where -- {{{ Imports-import Hbro.Config-import Hbro.Core+import Hbro.Core hiding(goBack, goForward) import qualified Hbro.Extra.Bookmarks as Bookmarks import qualified Hbro.Extra.BookmarksQueue as Queue import Hbro.Extra.Clipboard@@ -65,6 +64,8 @@ -- Browse (([Control], "<Left>"), goBack), (([Control], "<Right>"), goForward),+ (([Alt], "<Left>"), goBackList),+ (([Alt], "<Right>"), goForwardList), (([Control], "s"), stopLoading), (([], "<F5>"), reload True), (([Shift], "<F5>"), reload False),@@ -197,6 +198,7 @@ -- Status bar statusBarScrollPosition browser+ statusBarZoomLevel browser statusBarPressedKeys browser statusBarLoadProgress browser statusBarURI browser
examples/ui.xml view
@@ -66,6 +66,15 @@ </child> <child>+ <object class="GtkLabel" id="zoom"></object>+ <packing>+ <property name="pack-type">GTK_PACK_END</property>+ <property name="fill">False</property>+ <property name="expand">False</property>+ </packing>+ </child>++ <child> <object class="GtkLabel" id="keys"></object> <packing> <property name="pack-type">GTK_PACK_END</property>
hbro.cabal view
@@ -1,5 +1,5 @@ Name: hbro-Version: 0.6.8+Version: 0.6.8.1 Synopsis: A minimal KISS compliant browser -- Description: Homepage: http://projects.haskell.org/hbro/@@ -17,9 +17,9 @@ Extra-source-files: examples/hbro.hs Data-files: examples/ui.xml -Source-repository head- Type: git- Location: git@twyk.tk/haskell-browser.git+--Source-repositVory head+-- Type: git+-- Location: git@twyk.tk/haskell-browser.git Library Build-depends:@@ -42,7 +42,6 @@ unix, zeromq-haskell Exposed-modules:- Hbro.Config, Hbro.Core, Hbro.Extra.Bookmarks, Hbro.Extra.BookmarksQueue,