diff --git a/Hbro/Config.hs b/Hbro/Config.hs deleted file mode 100644 --- a/Hbro/Config.hs +++ /dev/null @@ -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 -} diff --git a/Hbro/Core.hs b/Hbro/Core.hs --- a/Hbro/Core.hs +++ b/Hbro/Core.hs @@ -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 () diff --git a/Hbro/Extra/Misc.hs b/Hbro/Extra/Misc.hs --- a/Hbro/Extra/Misc.hs +++ b/Hbro/Extra/Misc.hs @@ -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 "Unable to go forward !" 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 "Unable to go back !" 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) diff --git a/Hbro/Extra/StatusBar.hs b/Hbro/Extra/StatusBar.hs --- a/Hbro/Extra/StatusBar.hs +++ b/Hbro/Extra/StatusBar.hs @@ -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 $ "x" ++ escapeMarkup (show zoomLevel) ++ "" + 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 diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs --- a/Hbro/Gui.hs +++ b/Hbro/Gui.hs @@ -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 diff --git a/Hbro/Main.hs b/Hbro/Main.hs --- a/Hbro/Main.hs +++ b/Hbro/Main.hs @@ -1,7 +1,7 @@ module Main where -- {{{ Imports -import Hbro.Config +import Hbro.Core import Hbro.Types import Paths_hbro diff --git a/examples/hbro.hs b/examples/hbro.hs --- a/examples/hbro.hs +++ b/examples/hbro.hs @@ -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], ""), goBack), (([Control], ""), goForward), + (([Alt], ""), goBackList), + (([Alt], ""), goForwardList), (([Control], "s"), stopLoading), (([], ""), reload True), (([Shift], ""), reload False), @@ -197,6 +198,7 @@ -- Status bar statusBarScrollPosition browser + statusBarZoomLevel browser statusBarPressedKeys browser statusBarLoadProgress browser statusBarURI browser diff --git a/examples/ui.xml b/examples/ui.xml --- a/examples/ui.xml +++ b/examples/ui.xml @@ -66,6 +66,15 @@ + + + GTK_PACK_END + False + False + + + + GTK_PACK_END diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -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,