diff --git a/Hbro/Boot.hs b/Hbro/Boot.hs
--- a/Hbro/Boot.hs
+++ b/Hbro/Boot.hs
@@ -31,7 +31,7 @@
import Data.Functor
import Data.List
import qualified Data.Map as M hiding(null)
--- import Data.Maybe
+import Data.Maybe
import Data.Version
import Graphics.UI.Gtk.Abstract.Widget
@@ -47,6 +47,7 @@
import Prelude hiding(init)
+import System.Environment.XDG.BaseDir
import System.Exit
import System.Glib.Signals
import System.Posix.Files
@@ -64,54 +65,66 @@
when (opts^.Options.help) $ putStrLn Options.usage >> exitSuccess
when (opts^.Options.version) $ putStrLn (showVersion version) >> exitSuccess
- when (opts^.Options.verbose) . putStrLn $ "Commandline options: " ++ show opts
when (opts^.Options.recompile) $ Dyre.recompile >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure)
Dyre.wrap hbro' opts (setup, opts)
hbro' :: (K (), CliOptions) -> IO ()
-hbro' (customSetup, options) = do
+hbro' (customSetup, opts) = do
void $ installHandler sigINT (Catch onInterrupt) Nothing
- config <- runReaderT initConfig options
- gui <- runReaderT initGUI options
+ when (opts^.Options.verbose) . putStrLn $ "Commandline options: " ++ show opts ++ "\n"
- (result, logs) <- withIPC options $ \ipc -> runK options config gui ipc $ main customSetup
+ config <- runReaderT initConfig opts
+ gui <- initGUI opts
+ (result, logs) <- withIPC opts $ \ipc -> runK opts config gui ipc $ main customSetup
+
either print return result
- unless (options^.Options.quiet) . unless (null logs) $ putStrLn logs
- unless (options^.Options.quiet) $ putStrLn "Exiting..."
+ unless (opts^.Options.quiet) . unless (null logs) $ putStrLn logs
+ unless (opts^.Options.quiet) $ putStrLn "Exiting..."
-- {{{ Initialization
initConfig :: (MonadBase IO m, OptionsReader m) => m (Config K)
initConfig = do
options <- readOptions id
- return $ id
+ return . id
. (options^.Options.quiet ? set verbosity Quiet ?? id)
. (options^.Options.verbose ? set verbosity Verbose ?? id)
$ def
-initGUI :: (MonadBase IO m, OptionsReader m) => m (GUI K)
-initGUI = do
- file <- Options.getUIFile
- fallback <- io $ getDataFileName "examples/ui.xml"
+initGUI :: (MonadBase IO m) => CliOptions -> m (GUI K)
+initGUI opts = do
+ result <- runErrorT . (`runReaderT` opts) $ do
+ file <- getUIFile
+ whenM (readOptions Options.verbose) . io . putStrLn $ "Building GUI from file " ++ file ++ "\n"
- file' <- io $ firstReadableOf [file, fallback]
+ io $ void GTK.initGUI
+ Gui.buildFrom file
+ either (\e -> io (putStrLn e >> exitFailure)) return result
- case file' of
- Just f -> do
- io $ void GTK.initGUI
- Gui.buildFrom f
- _ -> io $ putStrLn "No UI file found." >> exitFailure
+
+getUIFile :: (MonadBase IO m, OptionsReader m, MonadError String m) => m FilePath
+getUIFile = do
+ fileFromOption <- readOptions Options.uIFile
+ fileFromConfig <- io (getUserConfigDir "hbro" >/> "ui.xml")
+ fileFromPackage <- io $ getDataFileName "examples/ui.xml"
+
+ maybe
+ (throwError "[ERROR] No readable UI file found.")
+ return
+ =<< io (firstReadableOf . catMaybes $ [fileFromOption, Just fileFromConfig, Just fileFromPackage])
where
firstReadableOf [] = return Nothing
firstReadableOf (x:y) = do
- isReadable <- fileAccess x True False False
+ isThere <- fileExist x
+ isReadable <- case isThere of
+ False -> return False
+ True -> fileAccess x True False False
isReadable ? return (Just x) ?? firstReadableOf y
-
withIPC :: (MonadBaseControl IO m) => CliOptions -> (IPC -> m a) -> m a
withIPC options f = restoreM =<< (liftBaseWith $ \runInIO -> do
ZMQ.withContext $ \c -> do
@@ -138,7 +151,7 @@
bindTitleChanged =<< Gui.readGUI Gui.webView
-- Default web settings
- WS.set webSettingsMonospaceFontFamily "consolas"
+ WS.set webSettingsMonospaceFontFamily "inconsolata"
WS.set webSettingsEnableDeveloperExtras True
WS.set webSettingsEnableHtml5Database False
WS.set webSettingsEnableHtml5LocalStorage False
@@ -221,17 +234,19 @@
return webView'
-bindDownload :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, MonadError HError m) => WebView -> m ()
+bindDownload :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, NotificationReader m, MonadError HError m) => WebView -> m ()
bindDownload webView = do
void . liftBaseWith $ \runInIO -> on webView W.downloadRequested $ \d -> do
amount <- W.downloadGetTotalSize d
- --notify 5000 $ "Requested download: " ++ filename ++ " (" ++ show size ++ ")"
void . runInIO $ do
uri <- downloadGetUri d
filename <- downloadGetSuggestedFilename d
callback <- readConfig onDownload
- logV $ "Requested download <" ++ show uri ++ ">"
+
+ logV $ "Requested download <" ++ show uri ++ ">"
+ notify 5000 $ "Requested download: " ++ filename ++ " (" ++ show amount ++ ")"
+
callback uri filename amount
return False
@@ -327,7 +342,7 @@
case (Key.lookup allStrokes =<< M.lookup theMode theBindings) of
Just (Key.Leaf callback) -> Key.writeStatus Key.strokes [] >> callback `catchError` \e -> (io $ print e) >> notify 5000 (show e)
Just (Key.Branch _) -> Key.writeStatus Key.strokes allStrokes
- _ -> return () --}
+ _ -> return ()
return ()
_ -> return ()
return False
diff --git a/Hbro/Config.hs b/Hbro/Config.hs
--- a/Hbro/Config.hs
+++ b/Hbro/Config.hs
@@ -19,7 +19,6 @@
import qualified Data.Map as M
import Graphics.UI.Gtk.Gdk.EventM
-import Graphics.UI.Gtk.WebKit.WebNavigationAction
import Network.URI as N hiding(parseURI, parseURIReference)
@@ -51,8 +50,9 @@
makeLenses ''Config
instance Show (Config m) where
- show c = "Home page = " ++ (show $ c^.homePage)
- ++ "\nVerbosity = " ++ (show $ c^.verbosity)
+ show c = unlines [
+ "Home page = " ++ (show $ c^.homePage),
+ "Verbosity = " ++ (show $ c^.verbosity)]
-- | 'MonadReader' for 'Config'
@@ -72,17 +72,6 @@
modifyConfig :: (ConfigState n m) => Simple Lens (Config n) a -> (a -> a) -> m ()
modifyConfig l f = writeConfig l . f =<< readConfig l
-
-instance Eq NavigationReason where
- a == b = (fromEnum a) == (fromEnum b)
-
-instance Show NavigationReason where
- show WebNavigationReasonLinkClicked = "Link clicked"
- show WebNavigationReasonFormSubmitted = "Form submitted"
- show WebNavigationReasonBackForward = "Back/forward"
- show WebNavigationReasonReload = "Reload"
- show WebNavigationReasonFormResubmitted = "Form resubmitted"
- show WebNavigationReasonOther = "Other"
-- }}}
-- | Run an action unless verbosity is 'Quiet'
diff --git a/Hbro/Core.hs b/Hbro/Core.hs
--- a/Hbro/Core.hs
+++ b/Hbro/Core.hs
@@ -33,6 +33,7 @@
-- import Data.Foldable
-- import Data.Functor
import Data.IORef
+import Data.Maybe
import qualified Data.Map as M
import Graphics.UI.Gtk.Gdk.EventM
@@ -107,7 +108,7 @@
-- {{{ Default configuration
instance Default (Config K) where
def = Config {
- _homePage = maybe undefined id . N.parseURI $ "https://duckduckgo.com/",
+ _homePage = fromJust . N.parseURI $ "https://duckduckgo.com/",
_verbosity = Normal,
_keyBindings = defaultKeyBindings,
_commands = def,
diff --git a/Hbro/Dyre.hs b/Hbro/Dyre.hs
--- a/Hbro/Dyre.hs
+++ b/Hbro/Dyre.hs
@@ -1,8 +1,11 @@
-- | Dynamic reconfiguration. Designed to be imported as @qualified@.
-module Hbro.Dyre where
+module Hbro.Dyre (
+ wrap,
+ recompile
+) where
-- {{{ Imports
-import Hbro.Options
+import Hbro.Options hiding(recompile)
import Hbro.Util
import Config.Dyre
@@ -17,20 +20,23 @@
-- }}}
--- | Print various paths used for dynamic reconfiguration
+nullMain :: a -> IO ()
+nullMain = const $ return ()
+
+-- Print various paths used for dynamic reconfiguration
printPaths :: MonadBase IO m => m ()
printPaths = io $ do
- (a, b, c, d, e) <- getPaths (parameters $ const $ return ())
+ (a, b, c, d, e) <- getPaths $ parameters nullMain False
putStrLn $ unlines [
"Current binary: " ++ a,
"Custom binary: " ++ b,
"Config file: " ++ c,
"Cache directory: " ++ d,
- "Lib directory: " ++ e, []]
+ "Lib directory: " ++ e]
--- | Dynamic reconfiguration settings
-parameters :: (a -> IO ()) -> Params (Either String a)
-parameters main = defaultParams {
+-- Dynamic reconfiguration settings
+parameters :: (a -> IO ()) -> Bool -> Params (Either String a)
+parameters main verbose' = defaultParams {
projectName = "hbro",
showError = const Left,
realMain = main',
@@ -39,16 +45,17 @@
includeCurrentDirectory = False}
where
main' (Left e) = putStrLn e
- main' (Right x) = main x
+ main' (Right x) = do
+ when verbose' printPaths
+ main x
wrap :: (a -> IO ()) -> CliOptions -> a -> IO ()
wrap main opts args = do
- when (opts^.verbose) printPaths
- wrapMain ((parameters main) { configCheck = not $ opts^.vanilla }) $ Right args
+ wrapMain ((parameters main (opts^.verbose)) { configCheck = not $ opts^.vanilla }) $ Right args
-- | Launch a recompilation of the configuration file
recompile :: IO (Maybe String)
recompile = do
- customCompile (parameters $ const $ return ())
- getErrorString (parameters $ const $ return ())
+ customCompile $ parameters nullMain False
+ getErrorString $ parameters nullMain False
diff --git a/Hbro/Gui.hs b/Hbro/Gui.hs
--- a/Hbro/Gui.hs
+++ b/Hbro/Gui.hs
@@ -124,7 +124,7 @@
build b = io $ NotificationBar <$> builderGetObject b castToLabel "notificationLabel" <*> newIORef Nothing
instance (Monad m) => Buildable (GUI m) where
- build b = io $ do
+ build b = do
(webView', sWindow') <- build b
(window', wBox') <- build b
promptBar' <- build b
@@ -137,7 +137,7 @@
-- {{{ Util
--- | Return the casted GObject corresponding to the given name (set in the builder's XML file)
+-- | Return the casted 'GObject' corresponding to the given name (set in the builder's XML file)
getObject :: (MonadBase IO m, GUIReader n m, GObjectClass a) => (GObject -> a) -> String -> m a
getObject cast name = do
b <- readGUI builder
@@ -168,10 +168,10 @@
Prompt.init =<< readGUI promptBar
WebView.init w
- io $ windowSetDefault mw (Just w)
+ io . windowSetDefault mw $ Just w
-- Validate/cancel prompt
- e <- readGUI (promptBar.(Prompt.entry))
+ e <- readGUI $ promptBar.(Prompt.entry)
io . void $ on e keyPressEvent (f w)
-- Show window
@@ -195,7 +195,7 @@
initWindow :: (MonadBase IO m) => Window -> m ()
initWindow window = io $ do
- windowSetDefaultSize window 800 600
+ windowSetDefaultSize window 1024 768
widgetModifyBg window StateNormal (Color 0 0 10000)
void $ onDestroy window GTK.mainQuit
diff --git a/Hbro/Options.hs b/Hbro/Options.hs
--- a/Hbro/Options.hs
+++ b/Hbro/Options.hs
@@ -7,6 +7,7 @@
socketPath,
help,
quiet,
+ uIFile,
verbose,
version,
vanilla,
@@ -17,8 +18,7 @@
usage,
get,
getStartURI,
- getSocketURI,
- getUIFile)
+ getSocketURI)
where
-- {{{ Imports
@@ -41,7 +41,6 @@
import System.Console.GetOpt
import System.Directory
import System.Environment
-import System.Environment.XDG.BaseDir
import System.FilePath
import System.Posix.Process
-- }}}
@@ -155,9 +154,3 @@
dir <- io getTemporaryDirectory
pid <- io getProcessID
return $ "ipc://" ++ dir "hbro." ++ show pid
-
--- | Return UI descriptor (XML file) used to build the GUI
-getUIFile :: (MonadBase IO m, OptionsReader m) => m FilePath
-getUIFile = maybe getDefaultUIFile return =<< readOptions uIFile
- where
- getDefaultUIFile = io (getUserConfigDir "hbro" >/> "ui.xml")
diff --git a/Hbro/Prompt.hs b/Hbro/Prompt.hs
--- a/Hbro/Prompt.hs
+++ b/Hbro/Prompt.hs
@@ -92,7 +92,6 @@
void . onEntryChanged entry' $ \v -> io (readIORef onChanged') >>= \f -> f v
void . onEntryValidated entry' $ \v -> io (readIORef onValidated') >>= \f -> f v
- return ()
where
l = _description promptBar
entry' = _entry promptBar
diff --git a/Hbro/Webkit/WebView.hs b/Hbro/Webkit/WebView.hs
--- a/Hbro/Webkit/WebView.hs
+++ b/Hbro/Webkit/WebView.hs
@@ -5,7 +5,6 @@
-- {{{ Imports
import Hbro.Error
import Hbro.Network
---import Hbro.Types
import Hbro.Util
import Control.Monad.Base
diff --git a/README.rst b/README.rst
--- a/README.rst
+++ b/README.rst
@@ -53,9 +53,41 @@
Configuration
-------------
-By default, a minimal configuration file (see ``Hbro/Main.hs``) is used to build *hbro*. You can create your own at ``~/.config/hbro/hbro.hs`` to override it. Several extensions are provided with the * hbro-contrib_ * package, including a well-commented example of configuration file.
+By default, a minimal configuration file (see ``Hbro/Main.hs``) is used to build *hbro*. You can create your own at ``~/.config/hbro/hbro.hs`` to override it. Several extensions are provided with the * hbro-contrib_ * package, including a commented configuration file example.
+GUI layout
+----------
+
+The graphical layout is described in an XML file that is parsed by GtkBuilder_ to build up the whole GUI. This file is looked for in several places with the following order of priority:
+
+- the value from commandline option ``-u``;
+- the file ``~/.config/hbro.ui.xml``;
+- the file ``examples/ui.xml`` bundled with the package.
+
+You must at least define the following widgets with the adequate ``id`` attribute:
+
++-----------------------+-----------------------+
+| Type | ``id`` |
++=======================+=======================+
+| ``GtkWindow`` | ``mainWindow`` |
++-----------------------+-----------------------+
+| ``GtkVBox`` | ``windowBox`` |
++-----------------------+-----------------------+
+| ``GtkScrolledWindow`` | ``webViewParent`` |
++-----------------------+-----------------------+
+| ``GtkHBox`` | ``promptBox`` |
++-----------------------+-----------------------+
+| ``GtkLabel`` | ``promptDescription`` |
++-----------------------+-----------------------+
+| ``GtkEntry`` | ``promptEntry`` |
++-----------------------+-----------------------+
+| ``GtkHBox`` | ``statusBox`` |
++-----------------------+-----------------------+
+| ``GtkLabel`` | ``notificationLabel`` |
++-----------------------+-----------------------+
+
+
Known bugs and limitations
--------------------------
@@ -86,3 +118,4 @@
.. _ZeroMQ: http://www.zeromq.org/
.. _Dyre: https://github.com/willdonnelly/dyre
.. _hbro-contrib: http://hackage.haskell.org/package/hbro-contrib
+.. _GtkBuilder: https://developer.gnome.org/gtk3/stable/GtkBuilder.html
diff --git a/examples/ui.xml b/examples/ui.xml
--- a/examples/ui.xml
+++ b/examples/ui.xml
@@ -8,14 +8,14 @@
-
+