packages feed

hbro 1.0.0.0 → 1.1.0.0

raw patch · 25 files changed

+1651/−1351 lines, 25 filesdep +lensdep +transformers-basedep +zeromq3-haskelldep −cmdargsdep −zeromq-haskelldep ~dyre

Dependencies added: lens, transformers-base, zeromq3-haskell

Dependencies removed: cmdargs, zeromq-haskell

Dependency ranges changed: dyre

Files

Hbro.hs view
@@ -1,21 +1,13 @@ module Hbro (     module Hbro.Boot,+    module Hbro.Config,     module Hbro.Core,-    module Hbro.Default,-    module Hbro.Gui,-    module Hbro.Keys,-    module Hbro.Socket,-    module Hbro.Types,+    module Hbro.Error,     module Hbro.Util,-    module Hbro.Webkit.WebView ) where  import Hbro.Boot+import Hbro.Config import Hbro.Core-import Hbro.Default-import Hbro.Gui-import Hbro.Keys-import Hbro.Socket-import Hbro.Types+import Hbro.Error import Hbro.Util-import Hbro.Webkit.WebView
Hbro/Boot.hs view
@@ -1,149 +1,318 @@-{-# LANGUAGE FlexibleContexts, RankNTypes #-}-module Hbro.Boot where+{-# LANGUAGE ConstraintKinds, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes #-}+module Hbro.Boot (hbro) where  -- {{{ Imports+import Hbro.Config import Hbro.Core+import qualified Hbro.Dyre as Dyre+import Hbro.Error+import Hbro.Gui (GUI, GUIReader(..)) import qualified Hbro.Gui as Gui-import qualified Hbro.Prompt as Prompt-import qualified Hbro.Socket as Socket-import Hbro.Types+import Hbro.IPC (IPC, IPCReader, readIPC)+import qualified Hbro.IPC as IPC+import qualified Hbro.Keys as Key+import Hbro.Notification+import Hbro.Options (CliOptions)+import qualified Hbro.Options as Options import Hbro.Util-import Hbro.Webkit.WebView as WebView+import qualified Hbro.Webkit.WebSettings as WS+import Hbro.Webkit.WebView +-- import Control.Applicative import Control.Concurrent-import qualified Config.Dyre as D-import Config.Dyre.Compile-import Config.Dyre.Paths--import Control.Applicative+import Control.Conditional hiding(when, unless)+import Control.Lens hiding((??)) import Control.Monad-import Control.Monad.Error-import Control.Monad.Reader+import Control.Monad.Base+import Control.Monad.Error hiding(when)+import Control.Monad.Trans.Control --- import Data.Functor-import Data.IORef+import Data.Default+import Data.Functor+import Data.List+import qualified Data.Map as M hiding(null) -- import Data.Maybe -import Graphics.UI.Gtk.General.General hiding(initGUI)+import Graphics.UI.Gtk.Abstract.Widget+import Graphics.UI.Gtk.Gdk.EventM+import qualified Graphics.UI.Gtk.General.General as GTK+import qualified Graphics.UI.Gtk.WebKit.Download as W+import Graphics.UI.Gtk.WebKit.WebSettings+import Graphics.UI.Gtk.WebKit.WebNavigationAction+import Graphics.UI.Gtk.WebKit.WebPolicyDecision+import Graphics.UI.Gtk.WebKit.WebView as W -import Network.URI as N+import Prelude hiding(init) -import System.Console.CmdArgs import System.Directory-import System.FilePath+import System.Environment.XDG.BaseDir import System.Exit-import System.IO+import System.Glib.Signals import System.Posix.Signals-import qualified System.ZMQ as ZMQ+import qualified System.ZMQ3 as ZMQ -- }}} --- {{{ Commandline options-baseOptions :: CliOptions-baseOptions = CliOptions {-    __startURI      = def &= explicit &= name "u" &= name "uri"          &= typ "URI" &= help "URI to open at start-up",-    __vanilla       = def &= explicit &= name "1" &= name "vanilla"      &= help "Do not read custom configuration file.",-    __recompile     = def &= explicit &= name "r" &= name "recompile"    &= help "Force recompilation and do not launch browser.",-    __denyReconf    = def &= explicit             &= name "deny-reconf"  &= help "Deny recompilation even if the configuration file has changed.",-    __forceReconf   = def &= explicit             &= name "force-reconf" &= help "Force recompilation even if the configuration file hasn't changed.",-    __dyreDebug     = def &= explicit             &= name "dyre-debug"   &= help "Force the application to use './cache/' as the cache directory, and ./ as the configuration directory. Useful to debug the program without installation.",-    __masterBinary  = def &= explicit             &= name "dyre-master-binary"} --- | Available commandline options (cf hbro -h).-cliOptions :: Mode (CmdArgs CliOptions)-cliOptions = cmdArgsMode $ baseOptions-    &= verbosityArgs [explicit, name "verbose", name "v"] []-    &= versionArg [ignore]-    &= help "A minimal KISS-compliant browser."-    &= helpArg [explicit, name "help", name "h"]-    &= program "hbro"--- }}}+-- | Main function to call in the configuration file (cf file @Hbro/Main.hs@).+-- First, commandline options are parsed, then configuration is dynamically applied.+hbro :: K () -> (Config K -> Config K) -> IO ()+hbro setup f = do+    opts <- Options.get --- {{{ Dynamic reconfiguration--- | Print various paths used for dynamic reconfiguration-printDyrePaths :: IO ()-printDyrePaths = do-    (a, b, c, d, e) <- getPaths dyreParameters-    putStrLn $ unlines [-        "Current binary:  " ++ a,-        "Custom binary:   " ++ b,-        "Config file:     " ++ c,-        "Cache directory: " ++ d,-        "Lib directory:   " ++ e, []]+    when (opts^.Options.help)      $ putStrLn Options.usage >> exitSuccess+    when (opts^.Options.verbose)   . putStrLn $ "Commandline options: " ++ show opts+    when (opts^.Options.recompile) $ Dyre.recompile >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure) --- | Dynamic reconfiguration settings-dyreParameters :: D.Params (Either String (Config, Setup, CliOptions))-dyreParameters = D.defaultParams {-    D.projectName             = "hbro",-    D.showError               = \_ -> Left,-    D.realMain                = realMain,-    D.ghcOpts                 = ["-threaded"],-    D.statusOut               = hPutStrLn stderr,-    D.includeCurrentDirectory = False}+    Dyre.wrap hbro' opts (f, setup, opts) --- | Launch a recompilation of the configuration file-recompile :: IO (Maybe String)-recompile = do-    customCompile  dyreParameters-    getErrorString dyreParameters++hbro' :: (Config K -> Config K, K (), CliOptions) -> IO ()+hbro' (f, customSetup, options) = do+    config <- initConfig f options+    gui    <- initGUI config+    ipc    <- initIPC config++    void $ installHandler sigINT (Catch onInterrupt) Nothing+    (result, logs) <- runK options config gui ipc $ main customSetup++    either print return result+    unless (options^.Options.quiet) . unless (null logs) $ putStrLn logs+    unless (options^.Options.quiet) $ putStrLn "Exiting..."++-- {{{ Initialization+initConfig :: (MonadBase IO m) => (Config K -> Config K) -> CliOptions -> m (Config K)+initConfig f options = do+    socketDir' <- io $ getTemporaryDirectory+    theUIFile  <- io $ getUserConfigDir "hbro" >/> "ui.xml"+    let config = f+          . set socketDir socketDir'+          . set uIFile theUIFile+          . (options^.Options.quiet   ? set verbosity Quiet   ?? id)+          . (options^.Options.verbose ? set verbosity Verbose ?? id)+          $ def++    when (config^.verbosity == Verbose) . io . putStrLn $ "Start-up configuration: \n" ++ show config+    return config+++initGUI :: (MonadBase IO m) => Config K -> m (GUI K)+initGUI config = do+    io $ void GTK.initGUI+    Gui.buildFrom $ config^.uIFile+++initIPC :: (MonadBase IO m) => Config K -> m IPC+initIPC config = IPC.init =<< (IPC.getSocketPath $ config^.socketDir) -- }}} --- | Main function to call in the configuration file (cf 'Hbro.Main')--- First parse commandline options, then perform dynamic reconfiguration process-hbro :: Config -> Setup -> IO ()-hbro config startUp = do-    options <- cmdArgsRun cliOptions -    when (_recompile options) $-        recompile >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure)+main :: K () -> K ()+main customSetup = do+    threadSync <- fork socketMain -    D.wrapMain dyreParameters{ D.configCheck = not $ _vanilla options } $ Right (config, startUp, options)+    Gui.init +-- Bind hooks+    bindDownload          =<< Gui.readGUI Gui.webView+    bindKeys+    bindLoadFinished      =<< Gui.readGUI Gui.webView+    bindNavigationRequest =<< Gui.readGUI Gui.webView+    bindNewWebView        =<< Gui.readGUI Gui.webView+    bindNewWindow         =<< Gui.readGUI Gui.webView+    bindResourceOpened    =<< Gui.readGUI Gui.webView+    bindTitleChanged      =<< Gui.readGUI Gui.webView --- | Entry point called after dynamic recompilation.-realMain :: Either String (Config, Setup, CliOptions) -> IO ()-realMain (Left e) = putStrLn e-realMain (Right (config, Setup customSetup, options)) = do-    void $ installHandler sigINT (Catch interruptHandler) Nothing-    whenLoud printDyrePaths+-- Default web settings+    WS.set webSettingsMonospaceFontFamily               "consolas"+    WS.set webSettingsEnableDeveloperExtras             True+    WS.set webSettingsEnableHtml5Database               False+    WS.set webSettingsEnableHtml5LocalStorage           False+    WS.set webSettingsEnablePageCache                   True+    WS.set webSettingsEnablePlugins                     False+    WS.set webSettingsEnablePrivateBrowsing             False+    WS.set webSettingsEnableScripts                     False+    WS.set webSettingsEnableSpellChecking               False+    WS.set webSettingsEnableSpatialNavigation           True+    WS.set webSettingsEnableUniversalAccessFromFileUris True+    WS.set webSettingsEnableXssAuditor                  True+    WS.set webSettingsJSCanOpenWindowAuto               False -    gui        <- runReaderT Gui.build' config-    hooks      <- Hooks <$> newIORef Nothing <*> newIORef Nothing <*> newIORef Nothing-    startURI   <- getStartURI options-    keys       <- newIORef ""-    zmqContext <- ZMQ.init 1+-- Apply custom setup+    customSetup -    result <- runErrorT . (`runReaderT` Context options config gui zmqContext hooks keys) $ do-        threadSync <- fork Socket.open+-- Load startpage+    startURI <- Options.getStartURI+    maybe goHome load startURI -        Gui.setupWindow-        Gui.setupScrollWindow-        Prompt.setup-        WebView.setup-        customSetup+-- Main loop+    io GTK.mainGUI -        maybe goHome loadURI startURI    -- Load home page-        io mainGUI                       -- Main loop+-- Clean & close+    void . (`IPC.sendCommand` "QUIT") =<< IPC.getSocketPath =<< readConfig socketDir+    io $ takeMVar threadSync -        Socket.close-        io $ takeMVar threadSync+    io . ZMQ.close =<< readIPC IPC.receiver+    io . ZMQ.term =<< readIPC IPC.context -    either print return result -    ZMQ.term zmqContext-    logNormal "Exiting..."+-- | IPC thread that listens to commands from external world.+socketMain :: K ()+socketMain = do+    socket <- readIPC IPC.receiver +    whileTrue $ do+        message <- IPC.read socket+        logV $ "Received command: " ++ message ----getStartURI :: CliOptions -> IO (Maybe URI)-getStartURI options = case (__startURI options) of-    Just uri -> do-        fileURI <- doesFileExist uri-        case fileURI of-            True -> getCurrentDirectory >>= return . N.parseURIReference . ("file://" ++) . (</> uri)-            _    -> return $ N.parseURIReference uri-    _ -> return Nothing+        case words message of+            []                -> IPC.send socket "ERROR Empty command" >> return True+            "QUIT":[]         -> IPC.send socket "OK" >> return False+            command:arguments -> do+                commands' <- IPC.unwrap <$> readConfig commands+                case M.lookup command commands' of+                    Just callback -> (postGUISync' (callback arguments) >>= IPC.send socket) `catchError` (\_ -> IPC.send socket "ERROR")+                    _             -> IPC.send socket "ERROR Unknown command"+                return True+    return ()+  where+    whileTrue f = do+        result <- f+        result ? whileTrue f ?? return ()  ----interruptHandler :: IO ()-interruptHandler = logVerbose "Received SIGINT." >> mainQuit+onInterrupt :: (MonadBase IO m) => m ()+onInterrupt = io (putStrLn "Received SIGINT." >> GTK.mainQuit)+++-- {{{ Signals handlers+-- Triggered in 2 cases:+--  1/ Javascript window.open()+--  2/ Context menu "Open in new window"+bindNewWebView :: (MonadBase IO m, ConfigReader m m, MonadBaseControl IO m, MonadError HError m) => WebView -> m ()+bindNewWebView webView = do+    void . liftBaseWith $ \runInIO -> on webView W.createWebView $ \_frame -> do+        webView' <- webViewNew++        void . on webView' W.webViewReady $ return True+        void . on webView' W.navigationPolicyDecisionRequested $ \_ request _ decision -> do+            void . runInIO $ do+                callback <- readConfig onNewWindow+                uri      <- networkRequestGetUri request+                logV $ "New webview <" ++ show uri ++ ">"+                callback uri+            webPolicyDecisionIgnore decision+            return True++        return webView'+++bindDownload :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m 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 ++ ">"+            callback uri filename amount+        return False+++bindLoadFinished :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, Error e, Show e, MonadError e m) => WebView -> m ()+bindLoadFinished webView = do+    void . liftBaseWith $ \runInIO -> on webView W.loadFinished $ \_frame-> do+        void . runInIO $ do+            callback <- readConfig onLoadFinished+            logV "Load finished"+            callback `catchError` \e -> (io $ print e) -- >> notify 5000 (show e)+        return ()++bindNavigationRequest :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, MonadError HError m) => WebView -> m ()+bindNavigationRequest webView = do+    liftBaseWith $ \runInIO -> void . on webView W.navigationPolicyDecisionRequested $ \_frame request action decision -> do+        reason <- io $ webNavigationActionGetReason action+        button <- io $ toMouseButton <$> webNavigationActionGetButton action++        case (reason, button) of+            (WebNavigationReasonLinkClicked, Just b) -> void . runInIO $ do+                callback <- readConfig onLinkClicked+                uri      <- networkRequestGetUri request+                logV $ "Link clicked <" ++ show uri ++ ">"+                callback b uri+                io $ webPolicyDecisionIgnore decision+            _ -> {-void . runInIO $ do+                callback <- readConfig onLoadRequested+                uri      <- networkRequestGetUri request+                logV $ "Requested load <" ++ show uri ++ ">"+                callback uri-}+                io $ webPolicyDecisionUse decision+        return True+  where+    toMouseButton 1 = Just LeftButton+    toMouseButton 2 = Just MiddleButton+    toMouseButton 3 = Just RightButton+    toMouseButton _ = Nothing+++bindNewWindow :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, MonadError HError m) => WebView -> m ()+bindNewWindow webView = do+    liftBaseWith $ \runInIO -> void . on webView W.newWindowPolicyDecisionRequested $ \_frame request _action decision -> do+        void . runInIO $ do+            callback <- readConfig onNewWindow+            uri      <- networkRequestGetUri request+            logV $ "New window request <" ++ show uri ++ ">"+            callback uri+        webPolicyDecisionIgnore decision+        return True+        --either (\e -> io . putStrLn $ "WARNING: wrong URI given, unable to open new window.") (const $ return ()) result+++bindResourceOpened :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, MonadError HError m) => WebView -> m ()+bindResourceOpened webView = do+    liftBaseWith $ \runInIO -> void . on webView W.mimeTypePolicyDecisionRequested $ \_frame request mimetype decision -> do+        void . runInIO $ do+            callback <- readConfig onResourceOpened+            uri <- networkRequestGetUri request+            logV $ "Opening resource [MIME type=" ++ mimetype ++ " | uri=" ++ show uri ++ "]"+            action <- callback uri mimetype+            case action of+                Load -> io $ webPolicyDecisionUse      decision+                _    -> io $ webPolicyDecisionDownload decision+        return True+++bindTitleChanged :: (MonadBase IO m, MonadBaseControl IO m, ConfigReader m m, MonadError HError m) => WebView -> m ()+bindTitleChanged webView = do+    liftBaseWith $ \runInIO -> void . on webView W.titleChanged $ \_frame title -> void . runInIO $ do+        logV $ "Title changed to: " ++ title+        callback <- readConfig onTitleChanged+        callback title+++bindKeys :: (MonadBaseControl IO m, Key.StatusState m, ConfigReader m m, GUIReader m m, NotificationReader m, Error e, Show e, MonadError e m) => m ()+bindKeys = do+  wv <- readGUI Gui.webView+  liftBaseWith $ \runInIO -> void . on wv keyPressEvent $ do+    modifiers <- eventModifier+    keyVal    <- eventKeyVal++    case (Key.mkStroke modifiers keyVal) of+        Just newStroke -> void . io . runInIO $ do+            oldStrokes  <- Key.readStatus Key.strokes+            theMode     <- Key.readStatus Key.mode+            theBindings <- readConfig keyBindings+            f           <- readConfig onKeyStroke+            let allStrokes = oldStrokes ++ [newStroke]+            f allStrokes+            logV $ "Pressed keys: " ++ (intercalate  " " . map Key.serialize) allStrokes++            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 False
Hbro/Clipboard.hs view
@@ -3,26 +3,26 @@ module Hbro.Clipboard where  -- {{{ Imports--- import Hbro.Core-import Hbro.Types+import Hbro.Error import Hbro.Util +import Control.Monad.Base import Control.Monad.Error-import Control.Monad.IO.Class import Control.Monad.Trans.Control  import Graphics.UI.Gtk.General.Clipboard -- }}} ----requestText :: (ClipboardClass a, MonadIO m, MonadError HError m, MonadBaseControl IO m) => a -> ClipboardHook -> m ()-requestText clip f = liftBaseWith $ \runInIO -> clipboardRequestText clip $ \x -> void . runInIO . maybe (throwError $ OtherError "Empty clipboard") f $ x---- | Write given String to primary clipboard.-insert :: (MonadIO m) => String -> m ()+-- | Write given string to primary clipboard+insert :: (MonadBase IO m) => String -> m () insert text = io $ clipboardGet selectionPrimary >>= (`clipboardSetText` text) -with :: (MonadIO m, MonadBaseControl IO m, MonadError HError m) => (String -> m ()) -> m ()+-- | Feed given function with primary cliboard's content+with :: (MonadBaseControl IO m, MonadError HError m) => (String -> m a) -> m () with f = do     clip <- io $ clipboardGet selectionPrimary     requestText clip f++-- | Wrapping around 'clipboardRequestText' to be able to use any monad based on IO as callback+requestText :: (MonadBaseControl IO m, ClipboardClass a, MonadError HError m) => a -> (String -> m b) -> m ()+requestText clip f = liftBaseWith $ \runInIO -> clipboardRequestText clip $ \x -> void . runInIO . maybe (throwError EmptyClipboard) f $ x
+ Hbro/Config.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, TemplateHaskell, UndecidableInstances #-}+module Hbro.Config where++-- {{{ Imports+import qualified Hbro.Keys as Key+import Hbro.IPC+import Hbro.Util++-- import Control.Conditional+import Control.Lens hiding(set)+import Control.Monad.Base+import Control.Monad.Error  hiding(forM_, mapM_)+-- import Control.Monad.Writer hiding(forM_, mapM_)++-- import Data.Foldable (forM_, mapM_)+-- import Data.Functor+import Data.List+import Data.Map (Map)+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)++import Prelude hiding(mapM_)+-- }}}++-- {{{ Types+data ResourceAction  = Load | Download+data Verbosity       = Quiet | Normal | Verbose deriving(Eq, Show)++-- | Custom settings provided by the user+data Config m = Config {+-- Paths+    _socketDir        :: FilePath,                          -- ^ Directory where IPC sockets will be created (e.g. @/tmp@)+    _UIFile           :: FilePath,                          -- ^ Path to XML file describing UI (used by @GtkBuilder@)+    _homePage         :: URI,                               -- ^ Startup page+-- Parameters+    _verbosity        :: Verbosity,                         -- ^ Logs verbosity+-- Hooks+    _keyBindings      :: Map Key.Mode (Key.Bindings m),     -- ^ Key bindings+    _onDownload       :: URI -> String -> Int -> m (),      -- ^ Callback triggered when a download is requested+    _onKeyStroke      :: [Key.Stroke] -> m (),              -- ^ Callback triggered when a key is pressed+    _onLinkClicked    :: MouseButton -> URI -> m (),        -- ^ Callback triggered when a link is clicked+    _onLoadRequested  :: URI -> m (),                       -- ^ Callback triggered when a load is requested+    _onLoadFinished   :: m (),                              -- ^ Callback triggered when a load is finished+    _onNewWindow      :: URI -> m (),                       -- ^ Callback triggered when a new window is requested+    _onResourceOpened :: URI -> String -> m ResourceAction, -- ^ Callback triggered when opening a non HTML resource+    _onTitleChanged   :: String -> m (),                    -- ^ Callback triggered when document title is changed+    _commands         :: CommandsMap m                      -- ^ Commands recognized through IPC system+}++makeLenses ''Config++instance Show (Config m) where+    show c = "Socket directory = " ++ c^.socketDir+        ++ "\nUI file          = " ++ c^.uIFile+        ++ "\nHome page        = " ++ (show $ c^.homePage)+        ++ "\nVerbosity        = " ++ (show $ c^.verbosity)+++-- | 'MonadReader' for 'Config'+class (Monad m) => ConfigReader n m | m -> n where+    readConfig :: Simple Lens (Config n) a -> m a++-- | 'MonadWriter' for 'Config'+class (Monad m) => ConfigWriter n m | m -> n where+    writeConfig :: Simple Lens (Config n) a -> a -> m ()++-- | 'MonadState' for 'Config'+type ConfigState n m = (ConfigReader n m, ConfigWriter n m)++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"+-- }}}+++-- | Return socket URI used for the current process.+getSocketURI :: (MonadBase IO m, ConfigReader n m) => m String+getSocketURI = getSocketPath =<< readConfig socketDir++-- | Run an action unless verbosity is 'Quiet'+unlessQuiet :: (MonadBase IO m, ConfigReader n m) => m () -> m ()+unlessQuiet f = do+    quiet' <- readConfig verbosity+    case quiet' of+        Quiet -> return ()+        _     -> f++-- | Run an action when verbosity is 'Verbose'+whenLoud :: (MonadBase IO m, ConfigReader n m) => m () -> m ()+whenLoud f = do+    verbose' <- readConfig verbosity+    case verbose' of+        Verbose -> f+        _       -> return ()+++log, logV :: (MonadBase IO m, ConfigReader n m) => String -> m ()+log  = unlessQuiet . io . putStrLn+logV = whenLoud    . io . putStrLn++-- | Bind a keystrokes chain to a callback, in a given mode+bind :: (MonadBase IO m, ConfigState m m) => Key.Mode -> String -> m () -> m ()+bind mode strokes action = case newBindings of+    Just b -> do+        oldValue <- readConfig keyBindings+        let newValue = M.insertWith Key.merge mode b oldValue+        void $ writeConfig keyBindings newValue+        return ()+    _ -> return ()+  where+    newBindings = Key.mkBinding strokes action
Hbro/Core.hs view
@@ -1,28 +1,224 @@-{-# LANGUAGE FlexibleContexts, RankNTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies #-} module Hbro.Core where  -- {{{ Imports-import Hbro.Types+import qualified Hbro.Clipboard as Clipboard+import Hbro.Config+import Hbro.Error+import Hbro.Gtk.ScrolledWindow (Axis(..), Position(..))+import qualified Hbro.Gtk.ScrolledWindow as SW+import Hbro.Gui as GUI+import qualified Hbro.Keys as Keys+import Hbro.IPC+import Hbro.Network+import Hbro.Notification+import Hbro.Options (CliOptions, OptionsReader)+import qualified Hbro.Options as Options+import Hbro.Prompt (PromptReader)+import qualified Hbro.Prompt as Prompt import Hbro.Util as H-import Hbro.Webkit.WebView as WebView+import qualified Hbro.Webkit.WebView as W -import Control.Monad.Error  hiding(forM_, mapM_)-import Control.Monad.Reader hiding(forM_, mapM_)+import Control.Applicative+import Control.Conditional hiding(unless)+import Control.Lens hiding((??))+import Control.Monad+import Control.Monad.Base+import Control.Monad.Error  hiding(forM_, mapM_, unless)+import Control.Monad.Reader hiding(forM_, mapM_, unless)+import Control.Monad.Writer hiding(forM_, mapM_, unless)+import Control.Monad.Trans.Control  import Data.Default -- import Data.Foldable -- import Data.Functor+import Data.IORef+import qualified Data.Map as M +import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.General.General import Graphics.UI.Gtk.WebKit.WebDataSource-import Graphics.UI.Gtk.WebKit.WebFrame-import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.WebKit.WebFrame as W+import Graphics.UI.Gtk.WebKit.WebInspector+import Graphics.UI.Gtk.WebKit.WebView as W+import Graphics.UI.Gtk.Windows.Window +import Network.URI (URI, uriScheme)+import qualified Network.URI as N+ import Prelude hiding(concat, mapM_)++import qualified System.Glib.Attributes as G -- }}} +-- {{{ Types+--newtype (Monad m) => KT m a = KT { unKT :: ErrorT HError (WriterT String (ReaderT CliOptions (ReaderT (IORef (Config (KT m))) (ReaderT (GUI (KT m)) (ReaderT IPC m))))) a}+--    deriving (Applicative, Functor, Monad, MonadWriter String)+--type K = KT IO+newtype K a = K { unKT :: ErrorT HError (WriterT String (ReaderT CliOptions (ReaderT (IORef (Config K)) (ReaderT (GUI K) (ReaderT IPC (ReaderT (IORef Keys.Status) IO)))))) a}+    deriving (Applicative, Functor, Monad, MonadBase IO, MonadError HError, MonadWriter String)++{-instance MonadBase IO K where+    liftBase = K . lift . lift . lift . lift . lift . lift-}++instance MonadBaseControl IO K where+    newtype StM K a  = StK { unStK :: StM (ErrorT HError (WriterT String (ReaderT CliOptions (ReaderT (IORef (Config K)) (ReaderT (GUI K) (ReaderT IPC (ReaderT (IORef Keys.Status) IO))))))) a }+    liftBaseWith f   = K . liftBaseWith $ \runInBase -> f $ liftM StK . runInBase . unKT+    restoreM         = K . restoreM . unStK++instance ConfigReader K K where+    readConfig l = K $ (lift . lift . lift) ask >>= io . readIORef >>= return . view l++instance ConfigWriter K K where+    writeConfig l v = K $ (lift . lift . lift) ask >>= io . (`modifyIORef` set l v)++instance GUIReader K K where+    readGUI l = K $ (lift . lift . lift . lift) ask >>= return . view l++instance IPCReader K where+    readIPC l = K $ (lift . lift . lift . lift . lift) ask >>= return . view l++instance NotificationReader K where+    readNotification l = K $ (lift . lift . lift . lift) ask >>= return . view (notificationBar.l)++instance OptionsReader K where+    readOptions l = K $ (lift . lift) ask >>= return . view l++instance PromptReader K K where+    readPrompt l = K $ (lift . lift . lift . lift) ask >>= return . view (promptBar.l)++instance Keys.StatusReader K where+    readStatus l = K $ (lift . lift . lift . lift . lift . lift) ask >>= io . readIORef >>= return . view l++instance Keys.StatusWriter K where+    writeStatus l v = K $ (lift . lift . lift . lift . lift . lift) ask >>= io . (`modifyIORef` set l v)++runK :: CliOptions -> Config K -> GUI K -> IPC -> K a -> IO ((Either HError a), String)+runK options config gui ipc k = do+    config'    <- newIORef config+    keysStatus <- newIORef def+    (`runReaderT` keysStatus) . (`runReaderT` ipc) . (`runReaderT` gui) . (`runReaderT` config'). (`runReaderT` options) . runWriterT . runErrorT $ unKT k+++data CaseSensitivity = CaseSensitive | CaseInsensitive+data Direction       = Forward       | Backward+data Wrap            = Wrap          | NoWrap+data ZoomDirection   = In            | Out+-- }}}+++-- {{{ Default configuration+instance Default (Config K) where+    def = Config {+        _socketDir        = "/tmp",+        _UIFile           = "~/.config/hbro/ui.xml",+        _homePage         = maybe undefined id . N.parseURI $ "https://duckduckgo.com/",+        _verbosity        = Normal,+        _keyBindings      = defaultKeyBindings,+        _commands         = def,+        _onDownload       = defaultDownload,+        _onKeyStroke      = const $ return (),+        _onLinkClicked    = defaultLinkClicked,+        _onLoadFinished   = return (),+        _onLoadRequested  = \uri -> load uri,+        _onNewWindow      = \uri -> spawn "hbro" [show uri],+        _onResourceOpened = defaultResourceOpened,+        _onTitleChanged   = \title -> readGUI mainWindow >>= io . (`G.set` [ windowTitle G.:= ("hbro | " ++ title)])} -- return ()}++-- | List of default supported requests.+instance Default (CommandsMap K) where+    def = CommandsMap . M.fromList $ [+    -- Get information+        ("GET_URI",           \_arguments -> show <$> getURI),+        ("GET_TITLE",         \_arguments -> show <$> getTitle),+        ("GET_FAVICON_URI",   \_arguments -> show <$> getFaviconURI),+        ("GET_LOAD_PROGRESS", \_arguments -> show <$> getLoadProgress),+    -- Trigger actions+        ("LOAD_URI",          \arguments -> case arguments of+            uri:_ -> parseURIReference uri >>= load >> return "OK"+            _     -> return "ERROR Argument needed."),+        ("STOP_LOADING",      \_arguments -> stopLoading >> return "OK"),+        ("RELOAD",            \_arguments -> reload      >> return "OK"),+        ("GO_BACK",           \_arguments -> goBack      >> return "OK"),+        ("GO_FORWARD",        \_arguments -> goForward   >> return "OK"),+        ("ZOOM_IN",           \_arguments -> zoomIn      >> return "OK"),+        ("ZOOM_OUT",          \_arguments -> zoomOut     >> return "OK")]+++defaultDownload :: URI -> String -> Int -> K ()+defaultDownload _ _ _ = return ()++defaultLinkClicked :: (MonadBase IO m, MonadWriter String m, GUIReader n m) => MouseButton -> URI -> m ()+defaultLinkClicked MiddleButton uri = spawn "hbro" [show uri]+defaultLinkClicked _            uri = load uri+++defaultKeyBindings :: M.Map Keys.Mode (Keys.Bindings K)+defaultKeyBindings = M.singleton Keys.Normal $ Keys.toBindings [+    -- Browse+        ("M-<Left>",      goBack),+        ("M-<Right>",     goForward),+        ("C-<Escape>",    stopLoading),+        ("<F5>",          reload),+        ("C-r",           reload),+        ("C-<F5>",        reloadBypassCache),+        ("M-r",           reloadBypassCache),+        ("C-^",           scroll Horizontal (Absolute 0)),+        ("C-$",           scroll Horizontal (Absolute 100)),+        ("C-<Home>",      scroll Vertical   (Absolute 0)),+        ("C-<End>",       scroll Vertical   (Absolute 100)),+        ("M-<Home>",      goHome),+    -- Copy/paste+        ("C-c",           getURI   >>= Clipboard.insert . show), -- >> notify 5000 "URI copied to clipboard"),+        ("M-c",           getTitle >>= Clipboard.insert), -- >> notify 5000 "Page title copied to clipboard"),+        ("C-v",           Clipboard.with $ parseURIReference >=> load),+        ("M-v",           Clipboard.with $ \uri -> spawn "hbro" [uri]),+    -- Display+        ("C-+",           zoomIn),+        ("C--",           zoomOut),+        -- ("<F11>",         with (_window . _UI) windowFullscreen),+        -- ("<Escape>",      with (_window . _UI) windowUnfullscreen),+        ("C-b",           toggleVisibility =<< readGUI statusBar),+        ("C-u",           toggleSourceMode),+    -- Prompt+        ("C-o",           Prompt.readURI "Open URI" "" load),+        ("M-o",           getURI >>= \uri -> Prompt.readURI "Open URI " (show uri) load),+    -- Search+        ("/",             Prompt.iread "Search " "" $ searchText_ CaseInsensitive Forward Wrap),+        ("C-f",           Prompt.iread "Search " "" $ searchText_ CaseInsensitive Forward Wrap),+        ("?",             Prompt.iread "Search " "" $ searchText_ CaseInsensitive Backward Wrap),+        ("C-n",           void . searchText CaseInsensitive Forward  Wrap =<< Prompt.getEntryValue),+        ("C-N",           void . searchText CaseInsensitive Backward Wrap =<< Prompt.getEntryValue),+    -- Misc+        ("<Escape>",      Prompt.hide),+        ("C-i",           inspect),+        ("C-p",           printPage),+        ("C-t",           spawn "hbro" []),+        ("C-w",           quit)]++-- /!\ NetworkRequest's Haskell binding is missing the function "webkit_network_request_get_message", which makes it rather useless...+-- | Display content if webview can show the given MIME type, otherwise download it.+defaultResourceOpened :: (MonadBase IO m, GUIReader n m) => URI -> String -> m ResourceAction+defaultResourceOpened _uri mimetype = do+    canShow <- io . (`webViewCanShowMimeType` mimetype) =<< readGUI webView+    return (canShow ? Load ?? Download)+-- }}}+ -- {{{ Util-{-getState :: (MonadIO m, MonadError HError m, Typeable a) => String -> a -> m a+isCaseSensitive :: CaseSensitivity -> Bool+isCaseSensitive CaseSensitive = True+isCaseSensitive _             = False++isForward :: Direction -> Bool+isForward Forward = True+isForward _       = False++isWrapped :: Wrap -> Bool+isWrapped Wrap = True+isWrapped _    = False+++{-getState :: (MonadBase IO m, MonadError HError m, Typeable a) => String -> a -> m a getState key defaultValue = do     customMap <- gets _custom     let result = fromDynamic =<< M.lookup key customMap@@ -33,29 +229,115 @@             return defaultValue-} -- }}} -goHome :: (MonadIO m, MonadReader r m, HasConfig r, HasWebView r, MonadError HError m) => m ()-goHome = loadURI =<< asks _homePage+-- {{{ Getters+getFaviconURI :: (MonadBase IO m, GUIReader n m, MonadError HError m) => m URI+getFaviconURI = W.getIconUri =<< readGUI webView -quit :: (MonadIO m) => m ()+getLoadProgress :: (MonadBase IO m, GUIReader n m) => m Double+getLoadProgress = io . W.webViewGetProgress =<< readGUI webView++getURI :: (MonadBase IO m, GUIReader n m, MonadError HError m) => m URI+getURI = W.getUri =<< readGUI webView++getTitle :: (MonadBase IO m, GUIReader n m, MonadError HError m) => m String+getTitle = W.getTitle =<< readGUI webView+-- }}}+++-- {{{ Browsing+goHome :: (MonadBase IO m, GUIReader n m, ConfigReader n' m, MonadWriter String m) => m ()+goHome = load =<< readConfig homePage++load :: (MonadBase IO m, GUIReader n m, MonadWriter String m) => URI -> m ()+load uri = do+    tell $ "Loading URI: " ++ (show uri')+    io . (`W.webViewLoadUri` uri') =<< readGUI webView+  where+    uri' = case uriScheme uri of+             [] -> "http://" ++ show uri+             _  -> show uri++reload, reloadBypassCache :: (MonadBase IO m, GUIReader n m, MonadError HError m) => m ()+reload            = io . W.webViewReload =<< readGUI webView+reloadBypassCache = io . W.webViewReloadBypassCache =<< readGUI webView++stopLoading :: (MonadBase IO m, GUIReader n m, MonadWriter String m) => m ()+stopLoading = do+    io . W.webViewStopLoading =<< readGUI webView+    tell $ "Stopped loading"++goBack, goForward :: (MonadBase IO m, GUIReader n m, MonadError HError m) => m ()+goBack = do+    readGUI webView >>= io . W.webViewCanGoBack >>= (`unless` throwError CannotGoBack)+    io . W.webViewGoBack =<< readGUI webView+goForward = do+    readGUI webView >>= io . W.webViewCanGoForward >>= (`unless` throwError CannotGoForward)+    readGUI webView >>= io . W.webViewGoForward+-- }}}++-- {{{ Display+-- | Toggle source display.+-- Current implementation forces a refresh of current web page, which may be undesired.+toggleSourceMode :: (MonadBase IO m, GUIReader n m, MonadError HError m) => m ()+toggleSourceMode = do+    v <- readGUI webView+    io . W.webViewSetViewSourceMode v =<< (io $ not <$> W.webViewGetViewSourceMode v)+    reload++zoomIn, zoomOut :: (MonadBase IO m, GUIReader n m) => m ()+zoomIn  = io . W.webViewZoomIn  =<< readGUI webView+zoomOut = io . W.webViewZoomOut =<< readGUI webView++scroll :: (MonadBase IO m, GUIReader n m) => Axis -> Position -> m ()+scroll axis percentage = SW.scroll axis percentage =<< readGUI scrollWindow+++-- | Show web inspector for current webpage.+inspect :: (MonadBase IO m, GUIReader n m) => m ()+inspect = do+    inspector <- io . W.webViewGetInspector =<< readGUI webView+    io $ webInspectorInspectCoordinates inspector 0 0+-- }}}++-- {{{+searchText :: (MonadBase IO m, GUIReader n m) => CaseSensitivity -> Direction -> Wrap -> String -> m Bool+searchText s d w text = do+    v <- readGUI webView+    io $ W.webViewSearchText v text (isCaseSensitive s) (isForward d) (isWrapped w)++searchText_ :: (MonadBase IO m, GUIReader n m) => CaseSensitivity -> Direction -> Wrap -> String -> m ()+searchText_ s d w text = searchText s d w text >> return ()++printPage :: (MonadBase IO m, GUIReader n m) => m ()+printPage = io . W.webFramePrint =<< io . W.webViewGetMainFrame =<< readGUI webView++download :: (MonadBase IO m, ConfigReader m m) => URI -> m ()+download uri = do+    callback <- readConfig onDownload+    callback uri (show uri) 0+-- }}}++quit :: (MonadBase IO m) => m () quit = io mainQuit + -- {{{ Misc -- | Execute a javascript file on current webpage.-executeJSFile :: (MonadIO m) => FilePath -> WebView -> m ()-executeJSFile filePath webView = do-    logNormal $ "Executing Javascript file: " ++ filePath+executeJSFile :: (MonadBase IO m, MonadReader r m, MonadWriter String m) => FilePath -> WebView -> m ()+executeJSFile filePath webView' = do+    tell $ "Executing Javascript file: " ++ filePath     script <- io $ readFile filePath     let script' = unwords . map (++ "\n") . lines $ script -    io $ webViewExecuteScript webView script'+    io $ webViewExecuteScript webView' script' -- }}}  -- | Save current web page to a file, -- along with all its resources in a separated directory. -- Doesn't work for now, because web_resource_get_data's binding is missing... _savePage :: String -> WebView -> IO ()-_savePage _path webView = do-    frame        <- webViewGetMainFrame webView+_savePage _path webView' = do+    frame        <- webViewGetMainFrame webView'     dataSource   <- webFrameGetDataSource frame     _mainResource <- webDataSourceGetMainResource dataSource     _subResources <- webDataSourceGetSubresources dataSource
− Hbro/Default.hs 
@@ -1,152 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}-module Hbro.Default where---- {{{ Import-import qualified Hbro.Clipboard as Clipboard-import Hbro.Core-import Hbro.Keys-import Hbro.Gtk.ScrolledWindow-import Hbro.Gui-import qualified Hbro.Prompt as Prompt-import Hbro.Types-import Hbro.Util-import Hbro.Webkit.WebView--import Control.Applicative-import Control.Conditional-import Control.Monad.Error  hiding(mapM_)-import Control.Monad.Reader hiding(mapM_)--- import Control.Monad.State  hiding(mapM_)--- import Control.Monad.Trans.Control--import Data.Default--- import Data.Foldable--- import Data.Functor--import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.General.General-import Graphics.UI.Gtk.Entry.Entry-import Graphics.UI.Gtk.Gdk.EventM-import Graphics.UI.Gtk.WebKit.WebPolicyDecision-import Graphics.UI.Gtk.WebKit.WebNavigationAction-import Graphics.UI.Gtk.WebKit.WebView-import Graphics.UI.Gtk.Windows.Window--import Prelude hiding(mapM_)---- import Network.URI (URI)-import qualified Network.URI as N--import System.Directory-import System.Environment.XDG.BaseDir-import System.Glib.Attributes--- }}}---- | Default configuration.--- Homepage: DuckDuckGo, socket directory: system's temporary directory,--- UI file: ~/.config/hbro/, Webkit's default websettings, default key/command bindings.-instance Default Config where-    def = Config {-        __homePage          = maybe undefined id . N.parseURI $ "https://duckduckgo.com/",-        __socketDir         = getTemporaryDirectory,-        __UIFile            = getUserConfigDir "hbro" >/> "ui.xml",-        __commands          = def}--instance Default Setup where-  def = Setup $ do-    _ <- afterKeyPressed     $ emacsKeyHandler def []-    _ <- onNavigationRequest $ def-    _ <- onNewWebView        $ def-    _ <- onNewWindow         $ def-    _ <- onResourceOpened    $ def-    _ <- onTitleChanged      $ def-    return ()--instance Default NewWindowHook where-    def = NewWindowHook $ \_frame request _action decision -> do-        io $ webPolicyDecisionIgnore decision-        uri <- networkRequestGetUri request-        logVerbose $ "New window request: " ++ show uri-        spawn "hbro" ["-u", show uri]--        --either (\e -> io . putStrLn $ "WARNING: wrong URI given, unable to open new window.") (const $ return ()) result--instance Default NavigationHook where-    def = let f WebNavigationReasonLinkClicked (Just MiddleButton) uri decision = io $ webPolicyDecisionIgnore decision >> spawn "hbro" ["-u", show uri]-              f _ _ _ decision                                                  = io $ webPolicyDecisionUse decision-          in NavigationHook f---- /!\ NetworkRequest's Haskell binding is missing the function "webkit_network_request_get_message", which makes it rather useless...--- | Display content if webview can show the given MIME type, otherwise download it.-instance Default ResourceOpenedHook where-    def = ResourceOpenedHook $ \_uri mimetype decision -> do-        canShow <- io . (`webViewCanShowMimeType` mimetype) =<< asks _webview-        io $ (canShow ? webPolicyDecisionUse ?? webPolicyDecisionDownload) decision--instance Default TitleChangedHook where-    def = TitleChangedHook $ \title -> asks _mainWindow >>= io . (`set` [ windowTitle := ("hbro | " ++ title)])----- | Default key bindings.-instance Default KeysList where-  def = KeysList [-    -- Browse-        ("M-<Left>",      goBack),-        ("M-<Right>",     goForward),-        ("C-<Escape>",    stopLoading),-        ("<F5>",          reload),-        ("C-r",           reload),-        ("C-<F5>",        reloadBypassCache),-        ("M-r",           reloadBypassCache),-        ("C-^",           scroll Horizontal (Absolute 0)),-        ("C-$",           scroll Horizontal (Absolute 100)),-        ("C-<Home>",      scroll Vertical   (Absolute 0)),-        ("C-<End>",       scroll Vertical   (Absolute 100)),-        ("M-<Home>",      goHome),-    -- Copy/paste-        ("C-c",           getURI   >>= Clipboard.insert . show >> notify 5000 "URI copied to clipboard"),-        ("M-c",           getTitle >>= Clipboard.insert >> notify 5000 "Page title copied to clipboard"),-        ("C-v",           Clipboard.with $ parseURIReference >=> loadURI),-        ("M-v",           Clipboard.with $ \uri -> spawn "hbro" ["-u", uri]),-    -- Display-        ("C-+",           zoomIn),-        ("C--",           zoomOut),-        -- ("<F11>",         with (_window . _UI) windowFullscreen),-        -- ("<Escape>",      with (_window . _UI) windowUnfullscreen),-        ("C-b",           toggleVisibility =<< asks _statusBar),-        ("C-u",           toggleSourceMode),-    -- Prompt-        ("C-o",           Prompt.readURI "Open URI" "" loadURI),-        ("M-o",           getURI >>= \uri -> Prompt.readURI "Open URI " (show uri) loadURI),-    -- Search-        ("/",             Prompt.iread "Search " "" $ searchText_ CaseInsensitive Forward Wrap),-        ("C-f",           Prompt.iread "Search " "" $ searchText_ CaseInsensitive Forward Wrap),-        ("?",             Prompt.iread "Search " "" $ searchText_ CaseInsensitive Backward Wrap),-        ("C-n",           void . searchText CaseInsensitive Forward  Wrap =<< io . entryGetText . _entry =<< asks _promptBar),-        ("C-N",           void . searchText CaseInsensitive Backward Wrap =<< io . entryGetText . _entry =<< asks _promptBar),-    -- Misc-        ("<Escape>",      io . widgetHide . _box =<< asks _promptBar),-        ("C-i",           showWebInspector),-        ("C-p",           printPage),-        ("C-t",           spawn "hbro" []),-        ("C-w",           quit)]----- | List of default supported requests.-instance Default CommandsList where-    def = CommandsList [-    -- Get information-        ("GET_URI",           \_arguments -> show <$> getURI),-        ("GET_TITLE",         \_arguments -> show <$> getTitle),-        ("GET_FAVICON_URI",   \_arguments -> show <$> getFaviconURI),-        ("GET_LOAD_PROGRESS", \_arguments -> show <$> getLoadProgress),-    -- Trigger actions-        ("LOAD_URI",          \arguments -> case arguments of-            uri:_ -> parseURIReference uri >>= loadURI >> return "OK"-            _     -> return "ERROR Argument needed."),-        ("STOP_LOADING",      \_arguments -> stopLoading >> return "OK"),-        ("RELOAD",            \_arguments -> reload      >> return "OK"),-        ("GO_BACK",           \_arguments -> goBack      >> return "OK"),-        ("GO_FORWARD",        \_arguments -> goForward   >> return "OK"),-        ("ZOOM_IN",           \_arguments -> zoomIn      >> return "OK"),-        ("ZOOM_OUT",          \_arguments -> zoomOut     >> return "OK")]
+ Hbro/Dyre.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Dynamic reconfiguration. Designed to be imported as @qualified@.+module Hbro.Dyre where++-- {{{ Imports+import Hbro.Options+import Hbro.Util++import Config.Dyre+import Config.Dyre.Compile+import Config.Dyre.Paths++import Control.Lens+import Control.Monad.Base+import Control.Monad.Reader++import System.IO+-- }}}+++-- | Print various paths used for dynamic reconfiguration+printPaths :: MonadBase IO m => m ()+printPaths = io $ do+    (a, b, c, d, e) <- getPaths (parameters $ const $ return ())+    putStrLn $ unlines [+        "Current binary:  " ++ a,+        "Custom binary:   " ++ b,+        "Config file:     " ++ c,+        "Cache directory: " ++ d,+        "Lib directory:   " ++ e, []]++-- | Dynamic reconfiguration settings+parameters :: (a -> IO ()) -> Params (Either String a)+parameters main = defaultParams {+    projectName             = "hbro",+    showError               = const Left,+    realMain                = main',+    ghcOpts                 = ["-threaded"],+    statusOut               = hPutStrLn stderr,+    includeCurrentDirectory = False}+  where+    main' (Left e)  = putStrLn e+    main' (Right x) = 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+++-- | Launch a recompilation of the configuration file+recompile :: IO (Maybe String)+recompile = do+    customCompile  (parameters $ const $ return ())+    getErrorString (parameters $ const $ return ())
+ Hbro/Error.hs view
@@ -0,0 +1,45 @@+module Hbro.Error where++-- {{{ Imports+import Control.Monad.Error++import Data.Maybe++import Graphics.UI.Gtk.WebKit.Download+import Graphics.UI.Gtk.WebKit.NetworkRequest++import System.IO.Error+-- }}}++data HError =+    CannotGoBack+  | CannotGoForward+  | EmptyCallback+  | EmptyClipboard+  | EmptyDownloadURI Download+  | EmptyRequestURI NetworkRequest+  | EmptySuggestedFileName Download+  | InvalidIconURI+  | InvalidPageTitle+  | InvalidPageURI+  | InvalidURI String+  | IOE IOError+  | OtherError String++instance Error HError where+    strMsg = OtherError++instance Show HError where+    show CannotGoBack               = "Unable to go back: already at oldest page."+    show CannotGoForward            = "Unable to go forward: already at newest page."+    show (IOE e)                    = "IO error: " ++ ioeGetLocation e ++ ": " ++ fromMaybe "" (ioeGetFileName e) ++ " " ++ ioeGetErrorString e+    show InvalidIconURI             = "No favicon URI."+    show InvalidPageTitle           = "No page title."+    show InvalidPageURI             = "Invalid page URI."+    show (InvalidURI s)             = show s+    show (EmptyDownloadURI _)       = "Invalid download URI."+    show (EmptyClipboard)           = "Empty clipboard."+    show (EmptySuggestedFileName _) = "No suggested name for this download."+    show (EmptyRequestURI _)        = "Invalid request URI."+    show EmptyCallback              = "No callback defined."+    show (OtherError s)             = show s
− Hbro/Gtk/Entry.hs 
@@ -1,32 +0,0 @@-{-# LANGUAGE FlexibleContexts, RankNTypes #-}-module Hbro.Gtk.Entry where---- {{{ Imports-import Hbro.Types-import Hbro.Util---- import Control.Arrow-import Control.Monad.Error-import Control.Monad.Reader-import Control.Monad.Trans.Control--import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.Entry.Editable-import Graphics.UI.Gtk.Entry.Entry-import Graphics.UI.Gtk.Gdk.EventM--import System.Glib.Signals--- }}}---- Validate/cancel prompt-onEntryValidated :: (MonadIO m, MonadBaseControl IO m, MonadError HError m, MonadReader r m, HasConfig r, HasGUI r, HasPromptBar r, HasOptions r, HasZMQContext r, HasHooks r, EntryClass t) => t -> EntryHook -> m (ConnectId t)-onEntryValidated entry f = liftBaseWith $ \runInIO -> on entry keyPressEvent $ do-    key <- eventKeyName-    io $ when (key == "Return") $ do-        void . runInIO $ (io (entryGetText entry) >>= f) `catchError` \e -> io (print e) >> notify 5000 (show e)-    return False---- Incremental behavior-onEntryChanged :: (MonadIO m, MonadBaseControl IO m, MonadError HError m, MonadReader r m, HasConfig r, HasGUI r, HasPromptBar r, HasOptions r, HasZMQContext r, HasHooks r, EditableClass t, EntryClass t) => t -> EntryHook -> m (ConnectId t)-onEntryChanged entry f = liftBaseWith $ \runInIO -> on entry editableChanged $ do-    void . runInIO $ (io (entryGetText entry) >>= f) `catchError` \e -> io (print e) >> notify 5000 (show e)
Hbro/Gtk/ScrolledWindow.hs view
@@ -1,24 +1,27 @@+{-# LANGUAGE FlexibleContexts #-} module Hbro.Gtk.ScrolledWindow where  -- {{{ Imports import Hbro.Util-import Hbro.Types -import Control.Monad.IO.Class-import Control.Monad.Reader+import Control.Monad.Base  import Graphics.UI.Gtk.Misc.Adjustment import Graphics.UI.Gtk.Scrolling.ScrolledWindow -- }}} -getAdjustment :: (MonadIO m) => Axis -> ScrolledWindow -> m Adjustment+data Axis     = Horizontal | Vertical+data Position = Absolute Double | Relative Double+++getAdjustment :: (MonadBase IO m) => Axis -> ScrolledWindow -> m Adjustment getAdjustment Horizontal = io . scrolledWindowGetHAdjustment getAdjustment Vertical   = io . scrolledWindowGetVAdjustment   -- | General scrolling command.-scroll' :: (MonadIO m) => Axis -> Position -> ScrolledWindow -> m ()-scroll' axis percentage scrollWindow = io $ do+scroll :: (MonadBase IO m) => Axis -> Position -> ScrolledWindow -> m ()+scroll axis percentage scrollWindow = io $ do      adj     <- io . getAdjustment axis $ scrollWindow      page    <- io $ adjustmentGetPageSize adj      current <- io $ adjustmentGetValue adj@@ -30,6 +33,3 @@          limit x            = (x `max` lower) `min` (upper - page)       io $ adjustmentSetValue adj $ limit (shift percentage)--scroll :: (MonadIO m, MonadReader r m, HasScrollWindow r) => Axis -> Position -> m ()-scroll axis percentage = scroll' axis percentage =<< asks _scrollwindow
Hbro/Gui.hs view
@@ -1,28 +1,52 @@-{-# LANGUAGE DoRec, FlexibleContexts, FlexibleInstances #-}-module Hbro.Gui where+{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, TemplateHaskell #-}+module Hbro.Gui (+    Buildable(..),+    StatusBar(..),+    GUI(),+    GUIReader(..),+    mainWindow,+    inspectorWindow,+    scrollWindow,+    webView,+    promptBar,+    statusBar,+    notificationBar,+    builder,+    getObject,+    toggleVisibility,+    buildFrom,+    init)+where  -- {{{ Imports---import Hbro.Core-import Hbro.Util+import Hbro.Notification+import Hbro.Prompt (PromptBar(..), PromptReader(..)) import qualified Hbro.Prompt as Prompt-import Hbro.Types-import Hbro.Webkit.WebView+import Hbro.Util+import qualified Hbro.Webkit.WebView as WebView -import Control.Conditional+import Control.Applicative+import Control.Conditional hiding(when)+import Control.Lens hiding((??), view) import Control.Monad hiding(forM_, mapM_)-import Control.Monad.IO.Class-import Control.Monad.Reader+import Control.Monad.Base+import Control.Monad.Error  hiding(forM_, mapM_)+import Control.Monad.Trans.Control ---import Data.Foldable-import Data.Functor+-- import Data.Foldable+-- import Data.Functor+import Data.IORef  import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Abstract.Container import Graphics.UI.Gtk.Abstract.Box+import Graphics.UI.Gtk.Abstract.Object import Graphics.UI.Gtk.Abstract.Widget import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label-import qualified Graphics.UI.Gtk.General.General as GTK+import Graphics.UI.Gtk.Entry.Entry+import Graphics.UI.Gtk.Gdk.EventM+import Graphics.UI.Gtk.General.General as GTK import Graphics.UI.Gtk.Layout.HBox import Graphics.UI.Gtk.Layout.VBox import Graphics.UI.Gtk.Scrolling.ScrolledWindow@@ -30,91 +54,165 @@ import Graphics.UI.Gtk.WebKit.WebView hiding(webViewLoadUri) import Graphics.UI.Gtk.Windows.Window -import Prelude hiding(mapM_)+import Prelude hiding(init, mapM_) -import System.Glib.Attributes+import System.Glib.Attributes hiding(get, set)+import qualified System.Glib.Attributes as G (get, set) import System.Glib.Signals import System.Glib.Types -- }}} --- Util+-- {{{ Types+newtype StatusBar = StatusBar HBox++instance GObjectClass StatusBar where+    toGObject (StatusBar h) = toGObject h+    unsafeCastGObject g     = StatusBar $ unsafeCastGObject g+instance ObjectClass StatusBar+instance WidgetClass StatusBar+++data GUI m = GUI {+    _mainWindow         :: Window,+    _inspectorWindow    :: Window,+    _scrollWindow       :: ScrolledWindow,  -- ^ 'ScrolledWindow' containing the webview+    _webView            :: WebView,+    _promptBar          :: PromptBar m,+    _statusBar          :: StatusBar,+    _notificationBar    :: NotificationBar,+    _builder            :: Builder          -- ^ Builder object created from XML file+}++makeLenses ''GUI++-- | 'MonadReader' for 'GUI'+class (Monad m) => GUIReader n m | m -> n where+    readGUI :: Simple Lens (GUI n) a -> m a++-- | UI elements that can be built from a @GtkBuilder@ object (that is: an XML file)+class Buildable a where+    build :: (MonadBase IO m) => Builder -> m a++instance (Monad m) => Buildable (PromptBar m) where+    build b = io $ do+        l  <- builderGetObject b castToLabel "promptDescription"+        e  <- builderGetObject b castToEntry "promptEntry"+        b' <- builderGetObject b castToHBox  "promptBox"+        oC <- newIORef . const $ return ()+        oV <- newIORef . const $ return ()++        return $ PromptBar b' l e oC oV++instance Buildable (WebView, ScrolledWindow) where+    build b = io $ do+        window  <- builderGetObject b castToScrolledWindow "webViewParent"+        wv      <- webViewNew+        containerAdd window wv++        return (wv, window)++instance Buildable (Window, VBox) where+    build b = io $ do+        w  <- builderGetObject b castToWindow "mainWindow"+        b' <- builderGetObject b castToVBox "windowBox"+        return (w, b')++instance Buildable StatusBar where+    build b = io $ StatusBar <$> builderGetObject b castToHBox "statusBox"++instance Buildable NotificationBar where+    build b = io $ NotificationBar <$> builderGetObject b castToLabel "notificationLabel" <*> newIORef Nothing++instance (Monad m) => Buildable (GUI m) where+    build b = io $ do+        (webView', sWindow') <- build b+        (window', wBox')     <- build b+        promptBar'           <- build b+        statusBar'           <- build b+        notificationBar'     <- build b+        inspectorWindow'     <- initWebInspector webView' wBox'++        return $ GUI window' inspectorWindow' sWindow' webView' promptBar' statusBar' notificationBar' b+-- }}}+++-- {{{ Util -- | Return the casted GObject corresponding to the given name (set in the builder's XML file)-getObject :: (MonadIO m, MonadReader r m, HasGUI r, GObjectClass a) => (GObject -> a) -> String -> m a+getObject :: (MonadBase IO m, GUIReader n m, GObjectClass a) => (GObject -> a) -> String -> m a getObject cast name = do-    builder <- asks _builder-    io $ builderGetObject builder cast name+    b <- readGUI builder+    io $ builderGetObject b cast name -build' :: (MonadIO m, MonadReader r m, HasConfig r) => m GUI-build' = do-    xmlPath <- asks _UIFile-    io $ void GTK.initGUI--- Load XML-    xmlPath' <- io xmlPath-    logNormal $ "Loading GUI from " ++ xmlPath' ++ "... "-    builder <- io builderNew-    io $ builderAddFromFile builder xmlPath'--- Build components-    (webView, sWindow) <- build builder-    (window, wBox)     <- build builder-    promptBar          <- build builder-    statusBar          <- build builder-    notificationBar    <- build builder-    inspectorWindow    <- initWebInspector webView wBox+-- | Toggle a widget's visibility (provided for convenience).+toggleVisibility :: (MonadBase IO m, WidgetClass a) => a -> m ()+toggleVisibility widget = io $ do+    visibility <- G.get widget widgetVisible+    visibility ? widgetHide widget ?? widgetShow widget+-- }}}+++-- {{{ Initialization+buildFrom :: (Monad n, MonadBase IO m) => FilePath -> m (GUI n)+buildFrom uiFile = do+    b <- io builderNew+    io $ builderAddFromFile b uiFile+    build b+++init :: (MonadBase IO m, MonadBaseControl IO m, GUIReader m m, NotificationReader m, PromptReader m m, Error e, Show e, MonadError e m) => m ()+init = do+    w  <- readGUI webView+    mw <- readGUI mainWindow+    initWindow       mw+    initScrollWindow =<< readGUI scrollWindow+    Prompt.init      =<< readGUI promptBar+    WebView.init     w++    io $ windowSetDefault mw (Just w)++-- Validate/cancel prompt+    e <- readGUI (promptBar.(Prompt.entry))+    io . void $ on e keyPressEvent (f w)+ -- Show window-    io $ widgetShowAll window-    io $ widgetHide (_box promptBar)+    io . widgetShowAll =<< readGUI mainWindow+    Prompt.hide -    logNormal "Done."-    return $ GUI {-        __mainWindow      = window,-        __inspectorWindow = inspectorWindow,-        __scrollWindow    = sWindow,-        __webView         = webView,-        __promptBar       = promptBar,-        __statusBar       = statusBar,-        __notificationBar = notificationBar,-        __builder         = builder-    }+    return ()+  where+    f w = do+        key <- eventKeyName+        when (key == "Return" || key == "Escape") $ io $ do+            --runInIO clean+            widgetGrabFocus w+            return ()+        return False -setupScrollWindow :: (MonadIO m, MonadReader r m, HasGUI r) => m ()-setupScrollWindow = do-    window <- asks _scrollWindow-    io $ scrolledWindowSetPolicy window PolicyNever PolicyNever -instance Buildable (Window, VBox) where-    build builder = io $ do-        window <- builderGetObject builder castToWindow "mainWindow"-        box    <- builderGetObject builder castToVBox "windowBox"-        return (window, box)+initScrollWindow :: (MonadBase IO m) => ScrolledWindow -> m ()+initScrollWindow window = io $ scrolledWindowSetPolicy window PolicyNever PolicyNever -setupWindow :: (MonadIO m, MonadReader r m, HasGUI r) => m ()-setupWindow = do-    window <- asks _mainWindow-    io . windowSetDefault window . Just =<< asks _webView-    io $ windowSetDefaultSize window 800 600-    io $ widgetModifyBg window StateNormal (Color 0 0 10000)-    io . void $ onDestroy window GTK.mainQuit -instance Buildable StatusBar where-    build builder = io $ StatusBar <$> builderGetObject builder castToHBox "statusBox"+initWindow :: (MonadBase IO m) => Window -> m ()+initWindow window = io $ do+    windowSetDefaultSize window 800 600+    widgetModifyBg window StateNormal (Color 0 0 10000)+    void $ onDestroy window GTK.mainQuit -instance Buildable NotificationBar where-    build builder = io $ NotificationBar <$> builderGetObject builder castToLabel "notificationLabel" --- {{{ Web inspector-initWebInspector :: (MonadIO m) => WebView -> VBox -> m (Window)-initWebInspector webView windowBox = do -    inspector       <- io $ webViewGetInspector webView-    inspectorWindow <- io windowNew-    io $ set inspectorWindow [ windowTitle := "hbro | Web inspector" ]+initWebInspector :: (MonadBase IO m) => WebView -> VBox -> m (Window)+initWebInspector webView' windowBox = do+    inspector <- io $ webViewGetInspector webView'+    window'   <- io windowNew+    io $ G.set window' [ windowTitle := "hbro | Web inspector" ] -    _ <- io $ on inspector inspectWebView $ \_ -> do+    io . void . on inspector inspectWebView $ \_ -> do         view <- webViewNew-        containerAdd inspectorWindow view+        containerAdd window' view         return view-    -    _ <- io $ on inspector showWindow $ do-        widgetShowAll inspectorWindow++    io . void . on inspector showWindow $ do+        widgetShowAll window'         return True  -- TODO: when does this signal happen ?!@@ -124,9 +222,9 @@     _ <- io $ on inspector attachWindow $ do         webview <- webInspectorGetWebView inspector         case webview of-            Just view -> do -                widgetHide inspectorWindow-                containerRemove inspectorWindow view+            Just view -> do+                widgetHide window'+                containerRemove window' view                 widgetSetSizeRequest view (-1) 250                 boxPackEnd windowBox view PackNatural 0                 widgetShow view@@ -139,21 +237,13 @@         _ <- case webview of             Just view -> do                 containerRemove windowBox view-                containerAdd inspectorWindow view-                widgetShowAll inspectorWindow+                containerAdd window' view+                widgetShowAll window'                 return True             _ -> return False-        -        widgetShowAll inspectorWindow-        return True -    return inspectorWindow--- }}}+        widgetShowAll window'+        return True --- {{{ Util--- | Toggle a widget's visibility (provided for convenience).-toggleVisibility :: (MonadIO m, WidgetClass a) => a -> m ()-toggleVisibility widget = io $ do-    visibility <- get widget widgetVisible-    visibility ? widgetHide widget ?? widgetShow widget+    return window' -- }}}
+ Hbro/IPC.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleContexts, RankNTypes, TemplateHaskell #-}+-- | Designed to be imported as @qualified@.+module Hbro.IPC where++-- {{{ Imports+-- import Hbro.Error+import Hbro.Util++import Control.Lens hiding(Context, Rep)+import Control.Monad hiding(mapM_)+import Control.Monad.Base+-- import Control.Monad.Error hiding(mapM_)+-- import Control.Monad.Writer++import Data.ByteString.Char8 (pack, unpack)+--import Data.Foldable+import Data.Functor+import Data.Map (Map)++-- import Graphics.UI.Gtk.General.General++import Prelude hiding(log, mapM_, read)++import System.FilePath+import System.Posix.Process+-- import System.Posix.Types+-- import System.Process+import System.ZMQ3 as ZMQ hiding(close, init, message, receive, send, socket)+import qualified System.ZMQ3 as ZMQ (init, receive, send, socket)+-- }}}++-- {{{ Types+data IPC = IPC {+    _context  :: Context,+    _receiver :: Socket Rep}++-- | 'MonadReader' for 'IPC'+class IPCReader m where+    readIPC :: Simple Lens IPC a -> m a++makeLenses ''IPC++newtype CommandsMap m = CommandsMap { unwrap :: Map String ([String] -> m String) }+-- }}}++-- | Open a listening socket at given location+init :: (MonadBase IO m) => String -> m IPC+init uri = io $ do+    theContext <- ZMQ.init 1+    socket     <- ZMQ.socket theContext Rep+    bind socket uri+    return $ IPC theContext socket++-- | Return the socket path to use for the given browser's process ID.+getSocketPath :: (Functor m, MonadBase IO m) => FilePath -> m String+getSocketPath socketDir = ((("ipc://" ++ socketDir </> "hbro.") ++) . show) <$> io getProcessID++-- | Send message through given socket+send :: (MonadBase IO m, Sender a) => Socket a -> String -> m ()+send socket payload = io $ ZMQ.send socket [] (pack payload)++-- | Wait for a message to be received from given socket+read :: (MonadBase IO m, Receiver a) => Socket a -> m String+read socket = io $ unpack <$> ZMQ.receive socket++-- | Send a single command to the given socket (which must be 'Rep'), and return the answer+sendCommand :: (MonadBase IO m, IPCReader m) => String -> String -> m String+sendCommand socketURI command = do+    theContext <- readIPC context+    io $ withSocket theContext Req $ \socket -> do+      connect socket socketURI+      send socket command+      read socket++-- | Same as 'sendCommand', but for all running instances of the browser.+{-sendCommandToAll :: (MonadBase IO m, ConfigReader m m, IPCReader m) => String -> m [String]+sendCommandToAll command = do+    dir  <- readConfig socketDir+    getAllProcessIDs >>= mapM ((`sendCommand` command) . (`socketPath` dir))-}
Hbro/Keys.hs view
@@ -1,37 +1,136 @@-{-# LANGUAGE DoRec, FlexibleContexts, RankNTypes #-}-module Hbro.Keys where+{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, TemplateHaskell, TupleSections #-}+-- | Key bindings model.+-- Designed to be imported as @qualified@.+module Hbro.Keys (+    Tree(..),+    Stroke,+    Bindings,+    Mode(..),+    Status(..),+    mode,+    strokes,+    StatusReader(..),+    StatusWriter(..),+    StatusState,+    mkStroke,+    merge,+    lookup,+    deserialize,+    prefixMod,+    serialize,+    toString,+    mkBinding,+    toBindings)+where  -- {{{ Imports-import Hbro.Types-import Hbro.Util+-- import Hbro.Util +import Control.Lens import Control.Monad hiding(forM_)-import Control.Monad.Error hiding(forM_)---import Control.Monad.IO.Class-import Control.Monad.Reader hiding(forM_)-import Control.Monad.Trans.Control+-- import Control.Monad.Error hiding(forM_)+-- import Control.Monad.IO.Class+-- import Control.Monad.Reader hiding(forM_)+-- import Control.Monad.Trans.Control ---import Data.Foldable+import Data.Default+-- import Data.Foldable import Data.Functor-import Data.IORef+-- import Data.Monoid+import Data.Map (Map) import qualified Data.Map as M---import qualified Data.Set as S+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as S hiding(foldl)  import Graphics.UI.Gtk.Abstract.Widget+import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.Gdk.Keys+-- import Graphics.UI.Gtk.General.Enums -import Prelude hiding(mapM_)+import Prelude hiding(lookup, mapM_)+-- }}} ---import System.Console.CmdArgs (whenLoud)---import System.Glib.Signals++-- {{{ Types+-- | A tree implementation that labels edges+data Tree edge leaf = Empty | Leaf leaf | Branch (Map edge (Tree edge leaf)) deriving(Show)++-- | A single keystroke, i.e. a set of modifiers and a single key (its string description)+type Stroke = (Set Modifier, String)++-- | List of keys bound to actions+type Bindings m = Tree Stroke (m ())+++data Mode = Normal | Insert deriving(Eq, Ord)++-- | Global state+data Status = Status {+    _mode     :: Mode,     -- ^ Current mode+    _strokes  :: [Stroke]  -- ^ Previous keystrokes+    }++instance Default Status where+    def = Status Normal []++makeLenses ''Status++-- | 'MonadReader' for 'Status'+class StatusReader m where+    readStatus :: Simple Lens Status a -> m a++-- | 'MonadWriter' for 'Status'+class StatusWriter m where+    writeStatus :: Simple Lens Status a -> a -> m ()++-- | 'MonadState' for 'Status'+type (StatusState m) = (StatusReader m, StatusWriter m)++{-instance Monoid KeyMap where+    mempty = KeyBindings M.empty+    mappend (KeyBindings a) (KeyBindings b) = KeyBindings (mappend a b)-}++instance Ord Modifier where+    compare x y = compare (show x) (show y) -- }}} ++mkStroke :: [Modifier] -> KeyVal -> Maybe Stroke+mkStroke m k = Just . (S.fromList m,) =<< toString k+++--toTree :: Ord a => [([a], b)] -> Tree a b+--toTree = foldl merge Empty . map toBranch++toBranch :: Ord a => ([a], b) -> Tree a b+toBranch ([], a)    = Leaf a+toBranch ((h:t), a) = Branch (M.fromList [(h, toBranch (t, a))])++-- | In case of conflicts, the rightmost operand is preferred+merge :: Ord a => Tree a b -> Tree a b -> Tree a b+merge Empty      x          = x+merge x          Empty      = x+merge (Leaf _)   (Leaf b)   = Leaf b+merge (Leaf _)   (Branch b) = Branch b+merge (Branch _) (Leaf b)   = Leaf b+merge (Branch a) (Branch b) = Branch $ M.unionWith merge a b+++lookup :: Ord a => [a] -> Tree a b -> Maybe (Tree a b)+lookup _     Empty      = Nothing+lookup []    (Leaf x)   = Just (Leaf x)+lookup []    x          = Just x+lookup _     (Leaf _)   = Nothing+lookup (h:t) (Branch m) = M.lookup h m >>= lookup t++ -- | Convert a KeyVal to a String. -- For printable characters, the corresponding String is returned, except for the space character for which "<Space>" is returned. -- For non-printable characters, the corresponding keyName wrapped into "< >" is returned. -- For modifiers, Nothing is returned.-keyToString :: KeyVal -> Maybe String-keyToString keyVal = case keyToChar keyVal of+toString :: KeyVal -> Maybe String+toString keyVal = case keyToChar keyVal of     Just ' '    -> Just "<Space>"     Just char   -> Just [char]     _           -> case keyName keyVal of@@ -51,32 +150,45 @@         x                   -> Just ('<':x ++ ">")  +serialize :: Stroke -> String+serialize (m, k) = S.foldr (++) "" (S.map serializeMod m) ++ k --- | Look for a callback associated to the given keystrokes and trigger it, if any.-defaultKeyHandler :: KeysList -> KeyHook-defaultKeyHandler (KeysList keysList) keystrokes = case M.lookup keystrokes (M.fromList keysList) of-    Just callback -> callback-    _             -> return () --- | Emacs-like key handler.-emacsKeyHandler :: (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, HasKeys r, MonadError HError m, MonadBaseControl IO m)-                => KeysList     -- ^ Key bindings-                -> [String]     -- ^ List of prefix keys-                -> String-                -> m ()-emacsKeyHandler keysList prefixes keystrokes = do-    keys        <- asks _keys-    chainedKeys <- (++ keystrokes) <$> io (readIORef keys)+serializeMod :: Modifier -> String+serializeMod Control = "C-"+-- serializeMod Shift   = "S-"+serializeMod Alt     = "M-"+serializeMod _       = "" -    case elem chainedKeys prefixes of-        True -> do-            io $ writeIORef keys $ chainedKeys ++ " "-        _    -> do-            io $ writeIORef keys ""-            defaultKeyHandler keysList chainedKeys+-- | Parse a 'String' representation of a keystrokes chain+deserialize :: String -> Maybe [Stroke]+deserialize ""          = Just []+deserialize (' ':t)     = deserialize t+deserialize ('C':'-':t) = prefixMod Control =<< deserialize t+deserialize ('M':'-':t) = prefixMod Alt     =<< deserialize t+-- deserialize ('S':'-':t) = prefixMod Shift   =<< deserialize t+deserialize (k:' ':t)   = prepend k <$> deserialize t+deserialize (k:t)       = prefixVal k =<< deserialize t  +prefixMod :: Modifier -> [Stroke] -> Maybe [Stroke]+prefixMod modifier ((m, keys):t) = Just ((S.insert modifier m, keys):t)+prefixMod _        _             = Nothing --- | Convert key bindings list to a map.--- keysListToMap :: KeysList -> KeysMap--- keysListToMap = M.fromList . (map (\(a, b) -> ((S.fromList a, b), c)))++prefixVal :: Char -> [Stroke] -> Maybe [Stroke]+prefixVal k [] = Just [(S.empty, [k])]+prefixVal k ((modifiers, keys):t)+    | S.null modifiers = Just ((modifiers, k:keys):t)+    | otherwise        = Nothing+++prepend :: Char -> [Stroke] -> [Stroke]+prepend k x = (S.empty, [k]):x+++mkBinding :: String -> m () -> Maybe (Bindings m)+mkBinding keys action = toBranch . (, action) <$> deserialize keys++toBindings :: [(String, m ())] -> Bindings m+toBindings = foldl merge Empty . catMaybes . map (\(a, b) -> mkBinding a b)
Hbro/Main.hs view
@@ -3,11 +3,13 @@ -- {{{ Imports import Hbro -import Data.Default+import Control.Lens  import Paths_hbro -- }}} --- | Default main function provided as example.+-- | Default main function provided as example main :: IO ()-main = hbro (def { __UIFile = getDataFileName "examples/ui.xml" }) def+main = do+    theUIFile <- getDataFileName "examples/ui.xml"+    hbro (return ()) (set uIFile theUIFile)
+ Hbro/Network.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Functions from 'Network.URI' rewritten with 'MonadError' instead of 'Maybe'.+module Hbro.Network where++-- {{{ Imports+import Hbro.Error++import Control.Monad.Error++import Network.URI as N+-- }}}+++parseURIReference :: (MonadError HError m) => String -> m URI+parseURIReference uri = maybe (throwError $ InvalidURI uri) return $ N.parseURIReference uri+++parseURI :: (MonadError HError m) => String -> m URI+parseURI uri = maybe (throwError $ InvalidURI uri) return $ N.parseURI uri
+ Hbro/Notification.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts, RankNTypes, TemplateHaskell #-}+module Hbro.Notification where++-- {{{ Imports+import Hbro.Util++import Control.Lens+import Control.Monad.Base+import Control.Monad.Error hiding(forM_, mapM_)++import Data.Foldable+import Data.IORef++import Graphics.Rendering.Pango.Enums+import Graphics.UI.Gtk.Display.Label+import Graphics.UI.Gtk.General.General++import Prelude hiding(mapM_)+-- }}}++-- {{{ Types+data NotificationBar = NotificationBar {+    _label :: Label,+    _timer :: IORef (Maybe HandlerId)}++makeLenses ''NotificationBar++-- | 'MonadReader' for 'NotificationBar'+class NotificationReader m where+    readNotification :: Simple Lens NotificationBar a -> m a++-- | 'MonadWriter' for 'NotificationBar'+class (Monad m) => NotificationWriter m where+    writeNotification :: Simple Lens NotificationBar a -> a -> m a++-- | 'MonadState' for 'NotificationBar'+type NotificationState m = (NotificationReader m, NotificationWriter m)+-- }}}+++notify :: (Functor m, MonadBase IO m, NotificationReader m, Error e, MonadError e m) => Int -> String -> m ()+notify duration text = do+    label'  <- readNotification label+    handler <- readNotification timer++    io $ do+        labelSetAttributes label' [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}]+        labelSetMarkup label' text+        mapM_ timeoutRemove =<< readIORef handler++    newID <- io $ timeoutAdd (labelSetMarkup label' "" >> return False) duration+    io . void $ writeIORef handler (Just newID)+    return ()
+ Hbro/Options.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, RankNTypes, TemplateHaskell #-}+-- | Commandline options tools. Designed to be imported as @qualified@.+module Hbro.Options (+    CliOptions(),+    OptionsReader(..),+    startURI,+    help,+    quiet,+    verbose,+    vanilla,+    recompile,+    denyReconf,+    forceReconf,+    dyreDebug,+    usage,+    get,+    getStartURI)+where++-- {{{ Imports+import Hbro.Util++import Control.Conditional+import Control.Lens as L  hiding((??))+import Control.Monad.Base+import Control.Monad.Reader++import Data.Default+import Data.Functor++import Network.URI as N++import Prelude hiding(log)++import System.Console.GetOpt+import System.Directory+import System.Environment+import System.FilePath+-- }}}++-- {{{ Types+-- | Available commandline options (cf @hbro -h@).+data CliOptions = CliOptions {+    _startURI      :: Maybe String,+    _help          :: Bool,+    _quiet         :: Bool,+    _verbose       :: Bool,+    _vanilla       :: Bool,+    _recompile     :: Bool,+    _denyReconf    :: Bool,+    _forceReconf   :: Bool,+    _dyreDebug     :: Bool}+    deriving(Eq)++makeLenses ''CliOptions++instance Show CliOptions where+    show opts =+        (maybe "" ("URI=" ++) $ view startURI opts)+        ++ (view help        opts ? " HELP" ?? "")+        ++ (view quiet       opts ? " QUIET" ?? "")+        ++ (view verbose     opts ? " VERBOSE" ?? "")+        ++ (view vanilla     opts ? " VANILLA" ?? "")+        ++ (view recompile   opts ? " RECOMPILE" ?? "")+        ++ (view denyReconf  opts ? " DENY_RECONFIGURATION" ?? "")+        ++ (view forceReconf opts ? " FORCE_RECONFIGURATION" ?? "")+        ++ (view dyreDebug   opts ? " DYRE_DEBUG" ?? "")++instance Default CliOptions where+    def = CliOptions {+        _startURI     = Nothing,+        _help         = False,+        _quiet        = False,+        _verbose      = False,+        _vanilla      = False,+        _recompile    = False,+        _denyReconf   = False,+        _forceReconf  = False,+        _dyreDebug    = False}++-- | 'MonadReader' for 'CliOptions'+class OptionsReader m where+    readOptions :: Simple Lens CliOptions a -> m a++instance (Monad m) => OptionsReader (ReaderT CliOptions m) where+    readOptions l = return . view l =<< ask++instance OptionsReader ((->) CliOptions) where+    readOptions l = view l+-- }}}+++description :: [OptDescr (CliOptions -> CliOptions)]+description = [+    Option ['h']     ["help"]               (NoArg (\o -> o { _help      = True }))     "Print this help.",+    Option ['q']     ["quiet"]              (NoArg (\o -> o { _quiet     = True }))     "Do not print any log.",+    Option ['v']     ["verbose"]            (NoArg (\o -> o { _verbose   = True }))     "Print detailed logs.",+    Option ['1']     ["vanilla"]            (NoArg (\o -> o { _vanilla   = True }))     "Do not read custom configuration file.",+    Option ['r']     ["recompile"]          (NoArg (\o -> o { _recompile = True }))     "Only recompile configuration.",+    Option []        ["deny-reconf"]        (NoArg id)                                  "Do not recompile configuration even if it has changed.",+    Option []        ["force-reconf"]       (NoArg id)                                  "Recompile configuration before starting the program.",+    Option []        ["dyre-debug"]         (NoArg id)                                  "Use './cache/' as the cache directory and ./ as the configuration directory. Useful to debug the program."]++-- | Usage text (cf @hbro -h@)+usage :: String+usage = usageInfo "Usage: hbro [OPTIONS] [URI]" description++-- | Get and parse commandline options+get :: (MonadBase IO m) => m CliOptions+get = io $ do+    options <- getOpt' Permute description <$> getArgs+    case options of+        (opts, input, _, []) -> return $ set startURI ((null $ concat input) ? Nothing ?? Just (concat input)) (foldl (flip id) def opts)+        (_, _, _, _)         -> return def++-- | Get URI passed in commandline, check whether it is a file path or an internet URI+-- and return the corresponding normalized URI (that is: prefixed with "file://" or "http://")+getStartURI :: (MonadBase IO m, OptionsReader m) => m (Maybe URI)+getStartURI = do+    theURI <- readOptions startURI+    case theURI of+      Just uri -> do+          fileURI <- io $ doesFileExist uri+          case fileURI of+              True -> io getCurrentDirectory >>= return . N.parseURIReference . ("file://" ++) . (</> uri)+              _    -> return $ N.parseURIReference uri+      _ -> return Nothing
Hbro/Prompt.hs view
@@ -1,26 +1,46 @@-{-# LANGUAGE FlexibleContexts, RankNTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, TemplateHaskell #-} -- | Designed to be imported as @qualified@.-module Hbro.Prompt where+module Hbro.Prompt(+    PromptBar(..),+    onChanged,+    onValidated,+    entry,+    description,+    box,+    PromptReader(..),+    init,+    open,+    hide,+    clean,+    read,+    incrementalRead,+    iread,+    readURI,+    getEntryValue)+where  -- {{{ Imports---import Hbro.Core-import Hbro.Types+import Hbro.Error+-- import Hbro.Gui+import Hbro.Network+import Hbro.Notification import Hbro.Util-import Hbro.Gtk.Entry  import Control.Conditional hiding(when)+import Control.Lens hiding((??)) import Control.Monad hiding(forM_, mapM_)+import Control.Monad.Base import Control.Monad.Error hiding(forM_, mapM_, when)---import Control.Monad.IO.Class-import Control.Monad.Reader hiding(forM_, mapM_, when)+import Control.Monad.Writer import Control.Monad.Trans.Control -import Data.Foldable+-- import Data.Foldable+-- import Data.Functor import Data.IORef  import Graphics.Rendering.Pango.Enums import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.Builder+-- import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Display.Label import Graphics.UI.Gtk.Entry.Editable import Graphics.UI.Gtk.Entry.Entry@@ -29,108 +49,128 @@  import Network.URI hiding(parseURIReference) -import Prelude hiding(mapM_)+import Prelude hiding(init, mapM_, read)  import System.Glib.Signals -- }}} -instance Buildable PromptBar where-    build builder = io $ do-        label <- builderGetObject builder castToLabel "promptDescription"-        entry <- builderGetObject builder castToEntry "promptEntry"-        box   <- builderGetObject builder castToHBox  "promptBox"--        return $ PromptBar box label entry+-- {{{ Types+data PromptBar m = PromptBar {+    _box           :: HBox,+    _description   :: Label,+    _entry         :: Entry,+    _onChanged     :: IORef (String -> m ()),+    _onValidated   :: IORef (String -> m ())} -setup :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasPromptBar r, HasHooks r, HasWebView r, MonadError HError m) => m ()-setup = do-    label <- asks _promptDescription-    io $ labelSetAttributes label [allItalic, allBold]-    io $ labelSetAttributes label [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}]+makeLenses ''PromptBar -    entry <- asks _promptEntry-    io $ widgetModifyBase entry StateNormal $ Color 0 0 0-    io $ widgetModifyText entry StateNormal $ Color 32767 32767 32767+class (Monad m, Monad n) => PromptReader n m | m -> n where+    readPrompt :: Simple Lens (PromptBar n) a -> m a+-- }}}  -- Validate/cancel prompt-    webView <- asks _webview-    io . void . on entry keyPressEvent $ do-        key <- eventKeyName-        when (key == "Return" || key == "Escape") $ io $ do-            --runInIO clean-            widgetGrabFocus webView-            return ()-        return False+onEntryValidated :: (MonadBase IO m, MonadBaseControl IO m, NotificationReader m, Error e, Show e, MonadError e m, EntryClass t) => t -> (String -> m ()) -> m (ConnectId t)+onEntryValidated entry' f = liftBaseWith $ \runInIO -> on entry' keyPressEvent $ do+    key <- eventKeyName+    io $ when (key == "Return") $ do+        void . runInIO $ (io (entryGetText entry') >>= f) `catchError` \e -> io (print e) >> notify 5000 (show e)+    return False++-- Incremental behavior+onEntryChanged :: (MonadBaseControl IO m, NotificationReader m, Error e, Show e, MonadError e m, EditableClass t, EntryClass t) => t -> (String -> m ()) -> m (ConnectId t)+onEntryChanged entry' f = liftBaseWith $ \runInIO -> on entry' editableChanged $ do+    void . runInIO $ (io (entryGetText entry') >>= f) `catchError` \e -> io (print e) >> notify 5000 (show e)+++init :: (MonadBase IO m, MonadBaseControl IO m, NotificationReader m, Error e, Show e, MonadError e m) => PromptBar m -> m ()+init promptBar = do+    io $ labelSetAttributes l [allItalic, allBold]+    io $ labelSetAttributes l [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}]++    io $ widgetModifyBase entry' StateNormal $ Color 0 0 0+    io $ widgetModifyText entry' StateNormal $ Color 32767 32767 32767++    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+    onChanged'   = _onChanged promptBar+    onValidated' = _onValidated promptBar  -open :: (MonadIO m, MonadReader r m, HasPromptBar r) => String -> String -> m ()+open :: (Functor m, MonadBase IO m, PromptReader n m, MonadWriter String m) => String -> String -> m () open newDescription defaultText = do-    logVerbose "Opening prompt."-    entry <- asks _promptEntry-    io . (`labelSetText` newDescription) =<< asks _promptDescription-    io $ entrySetText entry defaultText-    io . widgetShow =<< asks _promptBox-    io $ widgetGrabFocus entry-    io $ editableSetPosition entry (-1)+    tell "Opening prompt."+    e <- readPrompt entry+    io . (`labelSetText` newDescription) =<< readPrompt description+    io $ entrySetText e defaultText+    io . widgetShow =<< readPrompt box+    io $ widgetGrabFocus e+    io $ editableSetPosition e (-1) +hide :: (MonadBase IO m, PromptReader n m) => m ()+hide = io . widgetHide =<< readPrompt box+ -- | Close prompt, clean its content and callbacks-clean :: (MonadIO m, MonadReader r m, HasHooks r, HasPromptBar r, MonadBaseControl IO m) => m ()+clean :: (MonadBase IO m, PromptReader n m) => m () clean = do-     entry <- asks _promptEntry-     io $ widgetRestoreText entry StateNormal-     io $ widgetModifyText entry StateNormal $ Color 32767 32767 32767-     io . widgetHide =<< asks _promptBox+     e <- readPrompt entry+     io $ (`widgetRestoreText` StateNormal) e+     io . widgetModifyText e StateNormal $ Color 32767 32767 32767+     hide -     asks _promptChanged   >>= \ref -> io $ readIORef ref >>= mapM_ signalDisconnect >> writeIORef ref Nothing-     asks _promptValidated >>= \ref -> io $ readIORef ref >>= mapM_ signalDisconnect >> writeIORef ref Nothing+     readPrompt onChanged   >>= io . (`writeIORef` return (return ()))+     readPrompt onValidated >>= io . (`writeIORef` return (return ()))+     return ()  -- | Open prompt bar with given description and default value, -- and register a callback to trigger at validation.-read :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasPromptBar r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m)+read :: (MonadBaseControl IO m, PromptReader m m, Error e, MonadError e m, MonadWriter String m)      => String        -- ^ Prompt description      -> String        -- ^ Initial value-     -> EntryHook     -- ^ Function to trigger when validating prompt value+     -> (String -> m ())    -- ^ Function to trigger when validating prompt value      -> m () read = read' False  -- | Same as 'read', but callback is triggered for each change in prompt's entry.-incrementalRead, iread :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, MonadError HError m) => String -> String -> EntryHook -> m ()+incrementalRead :: (MonadBase IO m, MonadBaseControl IO m, PromptReader m m, Error e, MonadError e m, MonadWriter String m) => String -> String -> (String -> m ())  -> m () incrementalRead = read' True--- | Alias for incrementalRead.-iread           = incrementalRead -read' :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, MonadError HError m) => Bool -> String -> String -> EntryHook -> m ()-read' incremental description startValue f = do+-- | Alias for 'incrementalRead'.+iread :: (MonadBaseControl IO m, PromptReader m m, Error e, MonadError e m, MonadWriter String m) => String -> String -> (String -> m ())  -> m ()+iread = incrementalRead++read' :: (MonadBaseControl IO m, PromptReader m m, Error e, MonadError e m, MonadWriter String m) => Bool -> String -> String -> (String -> m ()) -> m ()+read' incremental description' startValue f = do     clean-    open description startValue-    (PromptBar { _entry = entry }) <- asks _promptBar+    open description' startValue -    when incremental $ onEntryChanged entry f   >>= \i -> asks _promptChanged   >>= io . (`writeIORef` Just i)-    onEntryValidated entry (f >=> const clean)  >>= \i -> asks _promptValidated >>= io . (`writeIORef` Just i)+    when incremental $ readPrompt onChanged >>= io . (`writeIORef` f)+    readPrompt onValidated >>= io . (`writeIORef` (f >=> const clean))     return ()   -- | Same as 'read' for URI values-readURI :: (MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, MonadBaseControl IO m, MonadIO m, MonadError HError m)-        => String -> String -> EntryURIHook -> m ()-readURI description startValue callback = do+readURI :: (MonadBase IO m, PromptReader m m, MonadError HError m, MonadWriter String m) => String -> String -> (URI -> m ()) -> m ()+readURI description' startValue callback = do     clean-    open description startValue+    open description' startValue     checkURI startValue -    (PromptBar { _entry = entry }) <- asks _promptBar-    id1 <- onEntryChanged   entry $ checkURI-    id2 <- onEntryValidated entry $ parseURIReference >=> callback >=> const clean-    asks _promptChanged   >>= io . (`writeIORef` Just id1)-    asks _promptValidated >>= io . (`writeIORef` Just id2)+    readPrompt onChanged   >>= io . (`writeIORef` checkURI)+    readPrompt onValidated >>= io . (`writeIORef` (parseURIReference >=> callback >=> const clean))     return ()   where-    checkURI :: EntryHook-    checkURI value = do-        (PromptBar { _entry = entry }) <- asks _promptBar-        io $ widgetModifyText entry StateNormal color+    checkURI v = do+        e <- readPrompt entry+        io $ widgetModifyText e StateNormal color       where-        color = (isURIReference value) ? green ?? red+        color = (isURIReference v) ? green ?? red         green = Color     0 65535 0         red   = Color 65535     0 0+++getEntryValue :: (MonadBase IO m, PromptReader n m) => m String+getEntryValue = io . entryGetText =<< readPrompt entry
− Hbro/Socket.hs 
@@ -1,109 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--- | Designed to be imported as @qualified@.-module Hbro.Socket where---- {{{ Imports--- import Hbro.Core-import Hbro.Util-import Hbro.Types--import Control.Monad hiding(mapM_)-import Control.Monad.Error hiding(mapM_)--- import Control.Monad.IO.Class-import Control.Monad.Reader hiding(mapM_)-import Control.Monad.Trans.Control--import Data.ByteString.Char8 (pack, unpack)---import Data.Foldable-import Data.Functor-import qualified Data.Map as M--import Graphics.UI.Gtk.General.General--import Prelude hiding(log, mapM_, read)--import System.FilePath-import System.Posix.Process-import System.Posix.Types-import qualified System.ZMQ as ZMQ--- }}}---- | Open a response-socket at configured location, named hbro.<pid>, and start listening for commands.-open :: (MonadBaseControl IO m, MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => m ()-open = do-    pid       <- io getProcessID-    socketDir <- asks _socketDir-    path      <- socketPath pid <$> io socketDir-    socket    <- io . (`ZMQ.socket` ZMQ.Rep) =<< asks _ZMQContext--    logNormal $ "Opening socket at " ++ path-    io $ ZMQ.bind socket path-    readCommands socket-    io $ ZMQ.close socket-    return ()---- | Close the response socket by sending it the command "QUIT".--- Typically called when exiting application.-close :: (Functor m, MonadIO m, MonadReader r m, HasConfig r, HasZMQContext r) => m ()-close = do-    uri <- getPath-    logVerbose $ "Closing socket " ++ show uri ++ "..."-    void $ sendCommand uri "QUIT"---- | Listen for incoming requests from response socket.--- Parse received commands and feed the corresponding callback, if any.-readCommands :: (Functor m, MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => ZMQ.Socket ZMQ.Rep -> m ()-readCommands socket = do-    message <- read socket-    logVerbose $ "Received command: " ++ message--    case words message of-    -- Empty command-        [] -> send socket "ERROR Unknown command"-    -- Exit command-        ["QUIT"] -> send socket "OK"-    -- Valid command-        command:arguments -> do-            (CommandsList commands) <- asks _commands-            case M.lookup command (M.fromList commands) of-                Just callback -> (postGUISync' (callback arguments) >>= send socket) `catchError` (\_ -> send socket "ERROR")-                _             -> send socket "ERROR Unknown command"--            readCommands socket--postGUISync' :: (MonadBaseControl IO m) => m a -> m a-postGUISync' f = control $ \runInIO -> postGUISync (runInIO f)---- | Return socket URI used for the current process.-getPath :: (Functor m, MonadIO m, MonadReader r m, HasConfig r) => m String-getPath = do-    dir <- asks _socketDir-    pid <- io getProcessID-    socketPath pid <$> io dir---- | Return the socket path to use for the given browser's process ID.-socketPath :: ProcessID -> FilePath -> String-socketPath pid socketDir = "ipc://" ++ socketDir </> "hbro." ++ show pid---- |-send :: (MonadIO m) => ZMQ.Socket a -> String -> m ()-send socket payload = io $ ZMQ.send socket (pack payload) []--read :: (MonadIO m) => ZMQ.Socket a -> m String-read socket = io $ unpack <$> ZMQ.receive socket []---- | Send a single command (through a Request socket) to the given Response socket, and return the answer.-sendCommand :: (MonadIO m, MonadReader r m, HasZMQContext r) => String -> String -> m String-sendCommand socketURI command = do-    context <- asks _ZMQContext-    io $ ZMQ.withSocket context ZMQ.Req $ \socket -> do-      ZMQ.connect socket socketURI-      send socket command-      read socket---- | Same as 'sendCommand', but for all running instances of the browser.-sendCommandToAll :: (MonadIO m, MonadReader r m, HasConfig r, HasZMQContext r) => String -> m [String]-sendCommandToAll command = do-    dir  <- asks _socketDir-    dir' <- io dir-    (io getAllProcessIDs) >>= mapM ((`sendCommand` command) . (`socketPath` dir'))
− Hbro/Types.hs 
@@ -1,344 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, RankNTypes, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}-module Hbro.Types where---- {{{ Imports--- import Control.Applicative-import Control.Monad.Error-import Control.Monad.Reader-import Control.Monad.Trans.Control--import Data.Dynamic-import Data.IORef-import Data.Map-import Data.Maybe-import Data.Monoid---import Data.Set--import Graphics.UI.Gtk.Abstract.Object-import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.Builder-import Graphics.UI.Gtk.Display.Label-import Graphics.UI.Gtk.Entry.Entry-import Graphics.UI.Gtk.General.General-import Graphics.UI.Gtk.Gdk.EventM-import Graphics.UI.Gtk.Layout.HBox-import Graphics.UI.Gtk.Scrolling.ScrolledWindow-import Graphics.UI.Gtk.WebKit.Download-import Graphics.UI.Gtk.WebKit.NetworkRequest-import Graphics.UI.Gtk.WebKit.WebFrame-import Graphics.UI.Gtk.WebKit.WebNavigationAction-import Graphics.UI.Gtk.WebKit.WebPolicyDecision-import Graphics.UI.Gtk.WebKit.WebView-import Graphics.UI.Gtk.Windows.Window--import Network.URI--import System.Console.CmdArgs-import System.Glib.GObject-import System.Glib.Signals-import System.IO.Error-import qualified System.ZMQ as ZMQ--- }}}---- {{{ Error-data HError =-    CannotGoBack-  | CannotGoForward-  | EmptyCallback-  | EmptyDownloadURI Download-  | EmptyRequestURI NetworkRequest-  | EmptySuggestedFileName Download-  | InvalidIconURI-  | InvalidPageTitle-  | InvalidPageURI-  | InvalidURI String-  | IOE IOError-  | OtherError String--instance Error HError where-    strMsg = OtherError--instance Show HError where-    show CannotGoBack         = "Unable to go back: already at oldest page."-    show CannotGoForward      = "Unable to go forward: already at newest page."-    show (IOE e)              = "IO error: " ++ ioeGetLocation e ++ ": " ++ fromMaybe "" (ioeGetFileName e) ++ " " ++ ioeGetErrorString e-    show InvalidIconURI       = "No favicon URI."-    show InvalidPageTitle     = "No page title."-    show InvalidPageURI       = "Invalid page URI."-    show (InvalidURI s)       = show s-    show (EmptyDownloadURI _) = "Invalid download URI."-    show (EmptySuggestedFileName _) = "No suggested name for this download."-    show (EmptyRequestURI _)  = "Invalid request URI."-    show EmptyCallback        = "No callback defined."-    show (OtherError s)       = show s--- }}}--data Context = Context {-    __options    :: CliOptions,                 -- ^ Commandline options-    __config     :: Config,                     -- ^ Custom configuration provided by user-    __UI         :: GUI,-    __ZMQContext :: ZMQ.Context,-    __hooks      :: Hooks,-    __keys       :: IORef String-}---- {{{ Commandline options--- | Available commandline options (cf hbro -h).-data CliOptions = CliOptions {-    __startURI     :: Maybe String,-    __vanilla      :: Bool,-    __recompile    :: Bool,-    __denyReconf   :: Bool,-    __forceReconf  :: Bool,-    __dyreDebug    :: Bool,-    __masterBinary :: Maybe String-} deriving (Data, Typeable, Show, Eq)---class HasOptions m where-    _startURI   :: m -> Maybe String-    _vanilla    :: m -> Bool-    _recompile  :: m -> Bool--instance HasOptions CliOptions where-    _startURI  = __startURI-    _vanilla   = __vanilla-    _recompile = __recompile--instance HasOptions Context where-    _startURI  = __startURI . __options-    _vanilla   = __vanilla . __options-    _recompile = __recompile . __options--- }}}---- {{{ Configuration types--- | Custom settings provided by the user.-data Config = Config {-    __socketDir :: IO FilePath,             -- ^ Directory where ZeroMQ sockets will be created ("/tmp" for example)-    __UIFile    :: IO FilePath,             -- ^ Path to XML file describing UI (used by GtkBuilder)-    __homePage  :: URI,                     -- ^ Startup page-    __commands  :: CommandsList             -- ^ Commands recognized through 0MQ sockets-}---class HasConfig m where-    _socketDir :: m -> IO FilePath-    _UIFile    :: m -> IO FilePath-    _homePage  :: m -> URI-    _commands  :: m -> CommandsList--instance HasConfig Config where-    _socketDir = __socketDir-    _UIFile    = __UIFile-    _homePage  = __homePage-    _commands  = __commands--instance HasConfig Context where-    _socketDir = __socketDir . __config-    _UIFile    = __UIFile . __config-    _homePage  = __homePage . __config-    _commands  = __commands . __config---class HasKeys m where-    _keys :: m -> IORef String--instance HasKeys Context where-    _keys = __keys--class HasZMQContext m where-    _ZMQContext :: m -> ZMQ.Context--instance HasZMQContext Context where-    _ZMQContext = __ZMQContext--- }}}---- {{{ UI types--- | UI elements that can be built from GtkBuilder.-class Buildable a where-    build :: Builder -> ((MonadIO m) => m a)---data GUI = GUI {-    __mainWindow         :: Window,-    __inspectorWindow    :: Window,-    __scrollWindow       :: ScrolledWindow,  -- ^ 'ScrolledWindow' containing the webview-    __webView            :: WebView,-    __promptBar          :: PromptBar,-    __statusBar          :: StatusBar,       -- ^ Status bar's horizontal box-    __notificationBar    :: NotificationBar,-    __builder            :: Builder          -- ^ Builder object created from XML file-}--newtype StatusBar = StatusBar HBox--instance GObjectClass StatusBar where-    toGObject (StatusBar h) = toGObject h-    unsafeCastGObject g     = StatusBar $ unsafeCastGObject g--instance ObjectClass StatusBar-instance WidgetClass StatusBar--class HasGUI m where-    _mainWindow      :: m -> Window-    _inspectorWindow :: m -> Window-    _scrollWindow    :: m -> ScrolledWindow-    _webView         :: m -> WebView-    _promptBar       :: m -> PromptBar-    _statusBar       :: m -> StatusBar-    _notificationBar :: m -> NotificationBar-    _builder         :: m -> Builder---instance HasGUI GUI where-    _mainWindow      = __mainWindow-    _inspectorWindow = __inspectorWindow-    _scrollWindow    = __scrollWindow-    _webView         = __webView-    _promptBar       = __promptBar-    _statusBar       = __statusBar-    _notificationBar = __notificationBar-    _builder         = __builder---instance HasGUI Context where-    _mainWindow      = __mainWindow      . __UI-    _inspectorWindow = __inspectorWindow . __UI-    _scrollWindow    = __scrollWindow    . __UI-    _webView         = __webView         . __UI-    _promptBar       = __promptBar       . __UI-    _statusBar       = __statusBar       . __UI-    _notificationBar = __notificationBar . __UI-    _builder         = __builder         . __UI---class HasWebView m where-    _webview  :: m -> WebView--instance (HasGUI m) => HasWebView m where-    _webview = _webView---class HasScrollWindow m where-    _scrollwindow :: m -> ScrolledWindow--instance (HasGUI m) => HasScrollWindow m where-    _scrollwindow = _scrollWindow---data PromptBar = PromptBar {-    _box                    :: HBox,-    _description            :: Label,-    _entry                  :: Entry-}--class HasPromptBar m where-    _promptBox         :: m -> HBox-    _promptDescription :: m -> Label-    _promptEntry       :: m -> Entry--instance HasPromptBar PromptBar where-    _promptBox         = _box-    _promptDescription = _description-    _promptEntry       = _entry--instance HasPromptBar GUI where-    _promptBox         = _box . _promptBar-    _promptDescription = _description . _promptBar-    _promptEntry       = _entry . _promptBar--instance HasPromptBar Context where-    _promptBox         = _box . _promptBar . __UI-    _promptDescription = _description . _promptBar . __UI-    _promptEntry       = _entry . _promptBar . __UI---data NotificationBar = NotificationBar {-    _label   :: Label                          -- ^ Content-}--class HasNotificationBar m where-    _notificationbar :: m -> NotificationBar--instance (HasGUI m) => HasNotificationBar m where-    _notificationbar = _notificationBar--- }}}---- {{{ Hooks-data Hooks = Hooks {-    __notificationTimer :: IORef (Maybe HandlerId),-    __promptChanged     :: IORef (Maybe (ConnectId Entry)),-    __promptValidated   :: IORef (Maybe (ConnectId Entry))-}---class HasHooks m where---    _custom               :: IORef (Map String Dynamic)-    _notificationTimer  :: m -> IORef (Maybe HandlerId)-    _promptChanged      :: m -> IORef (Maybe (ConnectId Entry))-    _promptValidated    :: m -> IORef (Maybe (ConnectId Entry))--instance HasHooks (a, Hooks) where-    _notificationTimer = __notificationTimer . snd-    _promptChanged     = __promptChanged . snd-    _promptValidated   = __promptValidated . snd---instance HasHooks Context where-    _notificationTimer = __notificationTimer . __hooks-    _promptChanged     = __promptChanged . __hooks-    _promptValidated   = __promptValidated . __hooks---newtype Setup           = Setup (forall r m. (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, HasKeys r, MonadError HError m, MonadBaseControl IO m) => m ())-type ClipboardHook      = String -> (forall m. (MonadIO m, MonadError HError m, MonadBaseControl IO m) => m ())-type EntryHook          = String -> (forall r m. (MonadIO m, MonadBaseControl IO m, MonadError HError m, MonadReader r m, HasConfig r, HasGUI r, HasPromptBar r, HasOptions r, HasZMQContext r, HasHooks r) => m ())-type EntryURIHook       = URI -> (forall r m. (MonadIO m, MonadError HError m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasGUI r, HasPromptBar r, HasOptions r, HasZMQContext r, HasHooks r) => m ())-newtype DownloadHook       = DownloadHook (URI -> String -> Int -> forall r m. (MonadIO m, Functor m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m, MonadBaseControl IO m) => m ())-type KeyHook            = String -> forall r m. (MonadIO m, MonadBaseControl IO m, MonadError HError m, MonadReader r m, HasConfig r, HasGUI r, HasPromptBar r, HasOptions r, HasZMQContext r, HasHooks r, HasKeys r) => m ()-newtype LoadFinishedHook   = LoadFinishedHook (forall r m. (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m, MonadBaseControl IO m) => m ())-newtype NavigationHook     = NavigationHook (NavigationReason -> Maybe MouseButton -> URI -> WebPolicyDecision -> forall r m. (MonadIO m, Functor m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, MonadError HError m, MonadBaseControl IO m) => m ())-newtype NewWebViewHook     = NewWebViewHook (WebFrame -> forall r m. (MonadIO m, Functor m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, MonadError HError m, MonadBaseControl IO m) => m WebView)-newtype NewWindowHook      = NewWindowHook (WebFrame -> NetworkRequest -> WebNavigationAction -> WebPolicyDecision -> forall r m. (MonadIO m, Functor m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, MonadError HError m, MonadBaseControl IO m) => m ())-newtype ResourceOpenedHook = ResourceOpenedHook (URI -> String -> WebPolicyDecision -> forall r m. (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, MonadError HError m, MonadBaseControl IO m) => m ())-newtype TitleChangedHook   = TitleChangedHook (String -> forall r m. (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, MonadError HError m, MonadBaseControl IO m) => m ())--- }}}---- {{{ Missing instances from webkit-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"--- }}}---- {{{ Keys--- Note: for modifiers, lists are used for convenience purposes,--- but are transformed into sets internally, so that order and repetition don't matter.--- | List of bound keys.--- All callbacks are fed with the Context instance.-newtype KeysList      = KeysList (forall r m. (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, MonadError HError m, MonadBaseControl IO m) => [(String, m ())])--instance Monoid KeysList where-    mempty = KeysList []-    mappend (KeysList a) (KeysList b) = KeysList (mappend a b)----type KeysMap          = (MonadIO m, MonadReader Context m) => Map String (m ())---data KeyMode          = CommandMode | InsertMode--- }}}--newtype CommandsList = CommandsList ((Functor m, MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, MonadError HError m) => [(String, ([String] -> m String))])-type CommandsMap  = (MonadIO m, MonadReader Context m) => Map String ([String] -> m String)---- Boolean datatypes-data CaseSensitivity = CaseSensitive | CaseInsensitive-data Direction       = Forward       | Backward-data Wrap            = Wrap          | NoWrap--data Axis     = Horizontal | Vertical-data Position = Absolute Double | Relative Double
Hbro/Util.hs view
@@ -1,70 +1,58 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, RankNTypes #-} module Hbro.Util where  -- {{{ Imports-import Hbro.Types- import Control.Concurrent import Control.Exception import Control.Monad hiding(mapM_)-import Control.Monad.Error hiding(mapM_)-import Control.Monad.Reader hiding(mapM_)---import Control.Monad.IO.Class+import Control.Monad.Base+-- import Control.Monad.Error hiding(mapM_)+-- import Control.Monad.Reader hiding(mapM_) import Control.Monad.Trans.Control -import Data.Foldable+-- import Data.Foldable import Data.Functor-import Data.IORef import Data.List  import Graphics.Rendering.Pango.Enums-import Graphics.UI.Gtk.Display.Label-import Graphics.UI.Gtk.Gdk.EventM import Graphics.UI.Gtk.General.General-import Graphics.UI.Gtk.WebKit.Download as W-import Graphics.UI.Gtk.WebKit.NetworkRequest as W -import Network.URI (URI)-import qualified Network.URI as N+-- import qualified Network.URI as N  import Prelude hiding(log, mapM_) -import System.Console.CmdArgs import System.FilePath import qualified System.Info as Sys -- import System.IO-import System.IO.Error hiding(try) import System.Posix.Process import System.Posix.Types import System.Process -- }}} +-- {{{ Aliases/shortcuts -- | Alias for 'liftIO'-io :: MonadIO m => IO a -> m a-io = liftIO+io :: MonadBase IO m => IO a -> m a+io = liftBase  -- | Like 'forkIO' using 'MVar' as thread control-fork :: (MonadIO m, MonadBaseControl IO m) => m () -> m (MVar ())+fork :: (MonadBaseControl IO m) => m () -> m (MVar ()) fork f = do     mvar <- io newEmptyMVar-    void . liftBaseWith $ \runInIO -> forkIO $ finally (void $ runInIO f) (putMVar mvar ())+    liftBaseWith $ \runInIO -> void . forkIO $ finally (void $ runInIO f) (putMVar mvar ())     return mvar --- | Like '</>' with first argument in IO to build platform-dependent paths.-(>/>) :: (MonadIO m) => IO FilePath -> FilePath -> m FilePath+-- | Like '(</>)' with first argument in IO to build platform-dependent paths.+(>/>) :: (MonadBase IO m) => IO FilePath -> FilePath -> m FilePath (>/>) a b = io $ (</> b) <$> a--logNormal, logVerbose :: (MonadIO m) => String -> m ()-logNormal  = io . whenNormal . putStrLn-logVerbose = io . whenLoud   . putStrLn+-- }}}  -- {{{ Process management -- | Run external command and won't kill when parent process exit.-spawn :: MonadIO m => String -> [String] -> m ()+spawn :: MonadBase IO m => String -> [String] -> m () spawn command options = io . void $ createProcess (proc command options) { std_in = CreatePipe,  std_out = CreatePipe, std_err = CreatePipe, close_fds = True }  -- | Return the list of process IDs corresponding to all running instances of the browser.-getAllProcessIDs :: MonadIO m => m [ProcessID]+getAllProcessIDs :: MonadBase IO m => m [ProcessID] getAllProcessIDs = do     (_, pids, _)  <- io $ readProcessWithExitCode "pidof" ["hbro"] []     (_, pids', _) <- io $ readProcessWithExitCode "pidof" ["hbro-" ++ Sys.os ++ "-" ++ Sys.arch] []@@ -73,75 +61,17 @@     return $ delete myPid . map (read :: String -> ProcessID) . nub . words $ pids ++ " " ++ pids' -- }}} --- | Set a temporary markup text to a label that disappears after some delay.-labelSetMarkupTemporary :: {-IORef HandlerId ->-} Label -> String -> Int -> IO ()-labelSetMarkupTemporary {-x-} label text delay = do-    --handler <- readIORef x-    --timeoutRemove handler -    labelSetMarkup label text-    timeoutAdd (clear >> return False) delay >> return () -- >>= writeIORef x-  where-    clear = labelSetMarkup label ""--errorHandler :: FilePath -> IOError -> IO ()+{-errorHandler :: (MonadBase IO m, MonadReader r m, HasOptions r) => FilePath -> IOError -> m () errorHandler file e = do-  when (isAlreadyInUseError e) $ (whenNormal . putStrLn) ("ERROR: file <" ++ file ++ "> is already opened and cannot be reopened.")-  when (isDoesNotExistError e) $ (whenNormal . putStrLn) ("ERROR: file <" ++ file ++ "> doesn't exist.")-  when (isPermissionError   e) $ (whenNormal . putStrLn) ("ERROR: user doesn't have permission to open file <" ++ file ++ ">.")---parseURIReference :: (MonadError HError m) => String -> m URI-parseURIReference uri = maybe (throwError $ InvalidURI uri) return $ N.parseURIReference uri--parseURI :: (MonadError HError m) => String -> m URI-parseURI uri = maybe (throwError $ InvalidURI uri) return $ N.parseURI uri--networkRequestGetUri :: (MonadIO m, MonadError HError m) => NetworkRequest -> m URI-networkRequestGetUri r = parseURIReference =<< maybe (throwError $ EmptyRequestURI r) return =<< io (W.networkRequestGetUri r)--downloadGetUri :: (MonadIO m, MonadError HError m) => W.Download -> m URI-downloadGetUri d               = parseURI =<< maybe (throwError $ EmptyDownloadURI d) return =<< io (W.downloadGetUri d)--downloadGetSuggestedFilename :: (MonadIO m, MonadError HError m) => W.Download -> m String-downloadGetSuggestedFilename d = maybe (throwError $ EmptySuggestedFileName d) return =<< io (W.downloadGetSuggestedFilename d)----- Boolean types conversion-isCaseSensitive :: CaseSensitivity -> Bool-isCaseSensitive CaseSensitive = True-isCaseSensitive _             = False--isForward :: Direction -> Bool-isForward Forward = True-isForward _       = False--isWrapped :: Wrap -> Bool-isWrapped Wrap = True-isWrapped _    = False+  when (isAlreadyInUseError e) $ unlessQuiet . io . putStrLn $ "ERROR: file <" ++ file ++ "> is already opened and cannot be reopened."+  when (isDoesNotExistError e) $ unlessQuiet . io . putStrLn $ "ERROR: file <" ++ file ++ "> doesn't exist."+  when (isPermissionError   e) $ unlessQuiet . io . putStrLn $ "ERROR: user doesn't have permission to open file <" ++ file ++ ">."-}  -- Common pango attributes allItalic, allBold :: PangoAttribute allItalic = AttrStyle  {paStart = 0, paEnd = -1, paStyle  = StyleItalic} allBold   = AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold} ---notify :: (Functor m, MonadIO m, MonadReader r m, HasNotificationBar r, HasHooks r, MonadError HError m) => Int -> String -> m ()-notify duration text = do-    label   <- _label <$> asks _notificationbar-    handler <- asks _notificationTimer--    io $ labelSetAttributes label [AttrForeground {paStart = 0, paEnd = -1, paColor = Color 32767 32767 32767}]-    io $ labelSetMarkup label text-    io $ mapM_ timeoutRemove =<< readIORef handler--    newID <- io $ timeoutAdd (labelSetMarkup label "" >> return False) duration-    io $ writeIORef handler $ Just newID---- | Convert a Modifier to a String.-stringify :: Modifier -> String-stringify Control = "C-"---stringify' Shift   = "S-"-stringify Alt     = "M-"-stringify _       = []+postGUISync' :: (MonadBaseControl IO m) => m a -> m a+postGUISync' f = control $ \runInIO -> postGUISync (runInIO f)
Hbro/Webkit/WebSettings.hs view
@@ -3,28 +3,36 @@ module Hbro.Webkit.WebSettings where  -- {{{ Imports---import Hbro.Core-import Hbro.Types+import Hbro.Gui import Hbro.Util -import Control.Monad.IO.Class-import Control.Monad.Reader+import Control.Monad+import Control.Monad.Base  import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.WebKit.WebView -import System.Glib.Attributes---- }}}+import System.Glib.Attributes as G+-- }}}  -modify :: (MonadIO m, MonadReader r m, HasWebView r) => Attr WebSettings a -> (a -> a) -> m a+set :: (MonadBase IO m, GUIReader n m) => Attr WebSettings a -> a -> m ()+set element newValue = modify_ element $ const newValue++modify :: (MonadBase IO m, GUIReader n m) => Attr WebSettings a -> (a -> a) -> m a modify element modifier = do-  webView <- asks _webview-  settings <- io $ webViewGetWebSettings webView-  oldValue <- io $ get settings element-  io $ set settings [element := modifier oldValue]-  io $ webViewSetWebSettings webView settings-  return oldValue+    w <- readGUI webView+    settings <- io $ webViewGetWebSettings w+    oldValue <- io $ get settings element+    io $ G.set settings [element := modifier oldValue]+    io $ webViewSetWebSettings w settings+    return oldValue -toggle :: (MonadIO m, MonadReader r m, HasWebView r) => Attr WebSettings Bool -> m Bool+modify_ :: (MonadBase IO m, GUIReader n m) => Attr WebSettings a -> (a -> a) -> m ()+modify_ e m = void $ modify e m++toggle :: (MonadBase IO m, GUIReader n m) => Attr WebSettings Bool -> m Bool toggle = (`modify` not)++toggle_ :: (MonadBase IO m, GUIReader n m) => Attr WebSettings Bool -> m ()+toggle_ = (`modify_` not)
Hbro/Webkit/WebView.hs view
@@ -1,34 +1,27 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, RankNTypes, TemplateHaskell #-} -- | Rewrite many 'Graphics.UI.Gtk.WebKit.WebView' functions in a monadic way.+-- Designed to be imported as @qualified@. module Hbro.Webkit.WebView where  -- {{{ Imports-import Hbro.Keys-import Hbro.Types+import Hbro.Error+import Hbro.Network+--import Hbro.Types import Hbro.Util -import Control.Conditional+import Control.Monad.Base import Control.Monad.Error  hiding(forM_, mapM_)-import Control.Monad.Reader hiding(forM_, mapM_)-import Control.Monad.Trans.Control+-- import Control.Monad.Reader hiding(forM_, mapM_) -import Data.Default-import Data.Foldable (forM_, mapM_)-import Data.Functor+-- import Data.Foldable (forM_, mapM_)+-- import Data.Functor -import Graphics.UI.Gtk.Abstract.Container import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.Builder-import Graphics.UI.Gtk.Gdk.EventM import qualified Graphics.UI.Gtk.General.General as GTK-import Graphics.UI.Gtk.Scrolling.ScrolledWindow-import qualified Graphics.UI.Gtk.WebKit.WebFrame as W import qualified Graphics.UI.Gtk.WebKit.Download as W+import Graphics.UI.Gtk.WebKit.NetworkRequest (NetworkRequest) import qualified Graphics.UI.Gtk.WebKit.NetworkRequest as W-import Graphics.UI.Gtk.WebKit.WebInspector-import Graphics.UI.Gtk.WebKit.WebNavigationAction-import Graphics.UI.Gtk.WebKit.WebPolicyDecision-import Graphics.UI.Gtk.WebKit.WebView (WebView, webViewNew)+import Graphics.UI.Gtk.WebKit.WebView (WebView) import qualified Graphics.UI.Gtk.WebKit.WebView as W  import Network.URI as N hiding(parseURI, parseURIReference)@@ -39,214 +32,28 @@ import System.Glib.Signals -- }}} --- {{{ Init-instance Buildable (WebView, ScrolledWindow) where-    build builder = io $ do-        window  <- builderGetObject builder castToScrolledWindow "webViewParent"-        webView <- W.webViewNew-        containerAdd window webView -        return (webView, window)--setup :: (MonadIO m, MonadReader r m, HasWebView r) => m ()-setup = do-    webView <- asks _webview-    io $ webView `set` [ widgetCanDefault := True ]-    io . void . on webView W.closeWebView $ GTK.mainQuit >> return False---- }}}+init :: (MonadBase IO m) => WebView -> m ()+init webView = io $ do+    set webView [ widgetCanDefault := True ]+    void . on webView W.closeWebView $ GTK.mainQuit >> return False  -- {{{ Monad-agnostic version of various WebKit functions-webViewGetUri :: (MonadIO m, MonadError HError m) => W.WebView -> m URI-webViewGetUri = maybe (throwError InvalidPageURI) parseURI <=< io . W.webViewGetUri--webViewGetTitle :: (MonadIO m, MonadError HError m) => W.WebView -> m String-webViewGetTitle = maybe (throwError InvalidPageTitle) return <=< io . W.webViewGetTitle--webViewGetIconUri :: (MonadIO m, MonadError HError m) => W.WebView -> m URI-webViewGetIconUri = maybe (throwError InvalidIconURI) parseURI <=< io . W.webViewGetUri--- }}}---- {{{ Getters-getFaviconURI :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => m URI-getFaviconURI = webViewGetIconUri =<< asks _webview--getLoadProgress :: (MonadIO m, MonadReader r m, HasWebView r) => m Double-getLoadProgress = io . W.webViewGetProgress =<< asks _webview--getURI :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => m URI-getURI = webViewGetUri =<< asks _webview--getTitle :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => m String-getTitle = webViewGetTitle =<< asks _webview--- }}}---- {{{ Browsing-loadURI :: (MonadIO m, MonadReader r m, HasWebView r) => URI -> m ()-loadURI uri = do-    logVerbose $ "Loading URI: " ++ (show uri')-    io . (`W.webViewLoadUri` uri') =<< asks _webview-  where-    uri' = case uriScheme uri of-             [] -> "http://" ++ show uri-             _  -> show uri--reload, reloadBypassCache :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => m ()-reload            = io . W.webViewReload =<< asks _webview-reloadBypassCache = io . W.webViewReloadBypassCache =<< asks _webview--stopLoading :: (MonadIO m, MonadReader r m, HasWebView r) => m ()-stopLoading = io . W.webViewStopLoading =<< asks _webview---    notify 5000 "Stopped loading"--goBack, goForward :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => m ()-goBack    = do-    view <- asks _webview-    unlessM (io $ W.webViewCanGoBack view) $ throwError CannotGoBack-    io $ W.webViewGoBack view-goForward = do-    view <- asks _webview-    unlessM (io $ W.webViewCanGoForward view) $ throwError CannotGoForward-    io $ W.webViewGoForward view--- }}}---- {{{ Display--- | Toggle source display.--- Current implementation forces a refresh of current web page, which may be undesired.-toggleSourceMode :: (MonadIO m, MonadReader r m, HasWebView r, MonadError HError m) => m ()-toggleSourceMode = do-    view <- asks _webview-    io . W.webViewSetViewSourceMode view =<< (io $ not <$> W.webViewGetViewSourceMode view)-    reload--zoomIn, zoomOut :: (MonadIO m, MonadReader r m, HasWebView r) => m ()-zoomIn  = io . W.webViewZoomIn  =<< asks _webview-zoomOut = io . W.webViewZoomOut =<< asks _webview---- | Show web inspector for current webpage.-showWebInspector :: (MonadIO m, MonadReader r m, HasWebView r) => m ()-showWebInspector = do-    inspector <- io . W.webViewGetInspector =<< asks _webview-    io $ webInspectorInspectCoordinates inspector 0 0--- }}}---- {{{ Hooks-afterKeyPressed :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, MonadError HError m, HasKeys r) => KeyHook -> m (ConnectId WebView)-afterKeyPressed f = do-  webView <- asks _webView-  liftBaseWith $ \runInIO -> after webView keyPressEvent $ do-    modifiers <- eventModifier-    key'      <- keyToString <$> eventKeyVal--    io . forM_ key' $ \key -> do-        let keystrokes = (++ key) . concat . map stringify $ modifiers-        logVerbose $ "Key pressed: " ++ keystrokes-        runInIO $ f keystrokes `catchError` \e -> (io $ print e) >> notify 5000 (show e)-    return False---- | Triggered in 2 cases:---  1/ Javascript window.open()---  2/ Context menu  "Open in new window"-onNewWebView :: (MonadIO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, HasKeys r, MonadError HError m) => NewWebViewHook -> m (ConnectId WebView)-onNewWebView (NewWebViewHook f) = do-    webView <- asks _webView-    env    <- ask-    io $ on webView W.createWebView $ \frame -> do-        result <- runErrorT . (`runReaderT` env) $ f frame-        case result of-            Left  e -> print e >> webViewNew-            Right r -> return r---instance Default NewWebViewHook where-    def = NewWebViewHook $ \_frame -> do-        --forM_ uri $ (runK env) . callback-        webView <- io webViewNew--        io . void . on webView W.webViewReady $ return True-        io . void . on webView W.navigationPolicyDecisionRequested $ \_ request _ decision -> do-            W.networkRequestGetUri request >>= mapM_ (\uri -> spawn "hbro" ["-u", uri])-            webPolicyDecisionIgnore decision-            return True--        return webView---onDownload :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => DownloadHook -> m (ConnectId WebView)-onDownload (DownloadHook f) = do-    webView <- asks _webView-    liftBaseWith $ \runInIO -> on webView W.downloadRequested $ \download -> do-      void . runInIO $ do-        uri      <- downloadGetUri download-        filename <- downloadGetSuggestedFilename download-        size     <- io $ W.downloadGetTotalSize download--        logVerbose $ "Requested download: " ++ show uri-        notify 5000 $ "Requested download: " ++ filename ++ " (" ++ show size ++ ")"-        f uri filename size-      return False---onLoadFinished :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => LoadFinishedHook -> m (ConnectId WebView)-onLoadFinished (LoadFinishedHook f) = do-    webView<- asks _webView-    liftBaseWith $ \runInIO -> on webView W.loadFinished $ \_frame-> void . runInIO $ do-        f `catchError` \e -> (io $ print e) >> notify 5000 (show e)--onNavigationRequest :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => NavigationHook -> m (ConnectId WebView)-onNavigationRequest (NavigationHook f) = do-  webView <- asks _webView-  liftBaseWith $ \runInIO -> on webView W.navigationPolicyDecisionRequested $ \_frame request action decision -> do-    void . runInIO $ do-      uri    <- networkRequestGetUri request-      reason <- io $ webNavigationActionGetReason action-      button <- io $ webNavigationActionGetButton action--      logVerbose $ "Requested navigation to <" ++ show uri ++ "> caused by " ++ show reason-      f reason (toMouseButton button) uri decision-    return True-  where-    toMouseButton 1 = Just LeftButton-    toMouseButton 2 = Just MiddleButton-    toMouseButton 3 = Just RightButton-    toMouseButton _ = Nothing-+getUri :: (MonadBase IO m, MonadError HError m) => WebView -> m URI+getUri = maybe (throwError InvalidPageURI) parseURI <=< io . W.webViewGetUri -onNewWindow :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => NewWindowHook -> m (ConnectId WebView)-onNewWindow (NewWindowHook f) = do-  webView <- asks _webView-  liftBaseWith $ \runInIO -> on webView W.newWindowPolicyDecisionRequested $ \frame request action decision -> do-    void $ runInIO (f frame request action decision)-    return True+getTitle :: (MonadBase IO m, MonadError HError m) => WebView -> m String+getTitle = maybe (throwError InvalidPageTitle) return <=< io . W.webViewGetTitle +getIconUri :: (MonadBase IO m, MonadError HError m) => WebView -> m URI+getIconUri = maybe (throwError InvalidIconURI) parseURI <=< io . W.webViewGetUri -onResourceOpened :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => ResourceOpenedHook -> m (ConnectId WebView)-onResourceOpened (ResourceOpenedHook f) = do-  webView <- asks _webView-  liftBaseWith $ \runInIO -> on webView W.mimeTypePolicyDecisionRequested $ \_frame request mimetype decision -> do-    void . runInIO $ do-      uri <- networkRequestGetUri request-      f uri mimetype decision-    return True+networkRequestGetUri :: NetworkRequest -> forall m. (MonadBase IO m, MonadError HError m) => m URI+networkRequestGetUri r = parseURIReference =<< maybe (throwError $ EmptyRequestURI r) return =<< io (W.networkRequestGetUri r) +downloadGetUri :: (MonadBase IO m, MonadError HError m) => W.Download -> m URI+downloadGetUri d = parseURI =<< maybe (throwError $ EmptyDownloadURI d) return =<< io (W.downloadGetUri d) -onTitleChanged :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m) => TitleChangedHook -> m (ConnectId WebView)-onTitleChanged (TitleChangedHook f) = do-    webView <- asks _webView-    liftBaseWith $ \runInIO -> on webView W.titleChanged $ \_frame title -> void . runInIO $ do-      logVerbose $ "Title changed to: " ++ title-      f title+downloadGetSuggestedFilename :: (MonadBase IO m, MonadError HError m) => W.Download -> m String+downloadGetSuggestedFilename d = maybe (throwError $ EmptySuggestedFileName d) return =<< io (W.downloadGetSuggestedFilename d) -- }}}---- | Wrapper around 'webViewSearchText', provided for convenience-searchText :: (MonadIO m, MonadReader r m, HasWebView r) => CaseSensitivity -> Direction -> Wrap -> String -> m Bool-searchText s d w text = do-    view <- asks _webview-    io $ W.webViewSearchText view text (isCaseSensitive s) (isForward d) (isWrapped w)--searchText_ :: (MonadIO m, MonadReader r m, HasWebView r) => CaseSensitivity -> Direction -> Wrap -> String -> m ()-searchText_ s d w text = searchText s d w text >> return ()---- | Wrapper around 'webFramePrint' function, provided for convenience.-printPage :: (MonadIO m, MonadReader r m, HasWebView r) => m ()-printPage = io . W.webFramePrint =<< io . W.webViewGetMainFrame =<< asks _webview
README.rst view
@@ -3,7 +3,7 @@ ====  -**In a nutshell**: *hbro* is a minimal KISS compliant browser for linux written, configured and extensible in Haskell.+**In a nutshell**: *hbro* is a minimal, KISS compliant browser for linux written, configured and extensible in Haskell.  Informations about versions, dependencies, source repositories and contacts can be found in hackage_. @@ -12,21 +12,19 @@ -----------------  `Do one thing well`_-  Browsing is about retrieving, presenting and traversing web resources. Not about providing tabs, bookmarks, history, download management, adblocking, passwords saving, self-updating, ... There already exists standalone applications for most extra features one may think of, please reuse them. Hbro can be configured to call external programs for any task.+  Browsing is about retrieving, presenting and traversing web resources. Not about providing tabs, bookmarks, history, download management, adblocking, passwords saving, self-updating, ... There already exists standalone applications for most extra features one may think of, please reuse them. *Hbro* can be configured to call external programs for any task.  `Keep It Simple, Stupid`_-  Hbro is written with simplicity in mind, and without an obsession for performance, features or release frequency. It may not be the fastest browser, at least it starts-up almost instantly, doesn't consume all your RAM and doesn't crash. Simplicity makes *hbro* lightweight, scalable, stable, easy to maintain and hack. Its code is easy to understand to encourage users to hack it.+  *Hbro* is written with simplicity in mind, and without obsession for performance, features or release frequency. It should not take time to start-up, consume much RAM or crash. Simplicity provides lightweightness, scalability, stability and maintainability. Its code is easy to understand (well, as long as you speak Haskell...) to encourage users to hack it.  Extensible-  Targets are advanced users who have various expectations ; to be sure everyone is happy, hbro is configured using a programming language, and offers an interprocess interface. As he who can do the most can do the least, the default configuration should be suitable for users that cannot afford or don't want to spend (waste ?) their time in tweaks.+  Targets are advanced users who have various expectations ; to be sure everyone is happy, *hbro* is configured using a programming language, and offers an interprocess interface. As he who can do the most can do the least, the default configuration should be suitable for users that cannot afford or don't want to spend (waste ?) their time in tweaks.  Keyboard driven-  Special attention is given to allow keyboard control of the browser whenever possible and not in conflict with another design principle.+  Special attention is given to allow keyboard control of the browser whenever possible.  Free software-  Hbro is distributed under the `Do-What-The-Fuck-You-Want-To public licence`_, which has a pretty self-explanatory name :) .--Note that some of these principles are taken from the `suckless manifest`_.+  Hbro is distributed under the `Do-What-The-Fuck-You-Want-To public licence`_, which has a pretty self-explanatory name.   Components and libraries used@@ -36,7 +34,7 @@   Modern, purely-functional language that makes it possible to work with a short, elegant and robust code.  Layout engine : WebKit_-  Webkit seems to be the only one being open-source, (kind of) standards-compliant and providing a Haskell binding. It's then not much of a choice, fortunately it's not that bad.+  Webkit seems to be the only engine being open-source, (kind of) standards-compliant and providing a Haskell binding. It's not much of a choice, fortunately it's not that bad.  UI toolkit : `GTK+`_   Given the above programming language and layout engine, there's no much choice left for the UI toolkit.@@ -48,7 +46,7 @@   Dynamic reconfiguration library for haskell programs.  -Suggestions about better alternatives for any of these points (except the programming language) are more than welcome :) .+Suggestions about better alternatives for any of these points (except the programming language) are welcome.   Configuration@@ -62,8 +60,8 @@  Patches or suggestions are welcome to deal with the following issues. See package description for contact address. -Flash videos make hbro freeze-  The demo webkit browser for haskell's binding has the same problem, so it doesn't seem to come from hbro itself.+The browser crashes on loading some webpages, and on enabling javascript/flash+  The demo webkit browser provided with haskell's binding crashes likewise, which suggests a problem in the haskell binding for webkit-gtk. Unfortunately, not much can be done on *hbro* itself to fix it.  .. Javascript's window.open requests open in the same window instead of spawning a new one.    This is due to this webkit's bug.@@ -81,7 +79,6 @@ .. _hackage: http://hackage.haskell.org/package/hbro .. _Do one thing well: http://en.wikipedia.org/wiki/Unix_philosophy .. _Keep It Simple, Stupid: https://en.wikipedia.org/wiki/KISS_principle-.. _suckless manifest: http://suckless.org/manifest/ .. _Do-What-The-Fuck-You-Want-To public licence: http://en.wikipedia.org/wiki/WTFPL .. _Haskell: http://haskell.org/ .. _WebKit: http://www.webkit.org/
hbro.cabal view
@@ -1,5 +1,5 @@ Name:                hbro-Version:             1.0.0.0+Version:             1.1.0.0 Synopsis:            Minimal KISS compliant browser -- Description: Homepage:            http://projects.haskell.org/hbro/@@ -27,38 +27,42 @@     Build-depends:         base == 4.*,         bytestring,-        cmdargs,         cond,         containers,         data-default,         directory,-        dyre,+        dyre >= 0.8.8,         filepath,         glib,         gtk >= 0.12.3,+        lens,         monad-control,         mtl,         network,         pango,         process,         transformers,+        transformers-base,         unix,         webkit,         xdg-basedir,-        zeromq-haskell+        zeromq3-haskell     Exposed-modules:         Hbro,         Hbro.Boot,-        Hbro.Default,         Hbro.Clipboard,+        Hbro.Config,         Hbro.Core,+        Hbro.Dyre,+        Hbro.Error,         Hbro.Gui,+        Hbro.IPC,         Hbro.Keys,+        Hbro.Network,+        Hbro.Notification,+        Hbro.Options,         Hbro.Prompt,-        Hbro.Socket,-        Hbro.Types,         Hbro.Util,-        Hbro.Gtk.Entry,         Hbro.Gtk.ScrolledWindow,         Hbro.Webkit.WebSettings,         Hbro.Webkit.WebView@@ -76,6 +80,7 @@         directory,         glib,         gtk,+        lens,         mtl     Main-is: Main.hs     Hs-Source-Dirs: Hbro